{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} module Data.Ord.Ordering where import Control.Category (Category(..) ) import Control.Lens ( view, isn't, (#), iso, prism', Getting, Prism', _Just, Iso ) import Control.Monad.State ( StateT, evalStateT ) import Data.Bool(bool) import Data.Functor.Identity ( Identity(..) ) import Data.Functor.Contravariant ( Contravariant(contramap) ) import Data.Functor.Contravariant.Divisible ( Decidable(..), Divisible(..) ) import Data.Void ( absurd ) import Prelude hiding (id, (.) ) type OrderingKnownEq = Maybe Ordering newtype Order b a = Order (a -> a -> b) class IsOrdering a where _Ordering :: Prism' a Ordering _LT :: Prism' a () _LT = forall a. IsOrdering a => Prism' a Ordering _Ordering forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b prism' (\() -> Ordering LT) (\case Ordering LT -> forall a. a -> Maybe a Just () Ordering _ -> forall a. Maybe a Nothing ) _EQ :: Prism' a () _EQ = forall a. IsOrdering a => Prism' a Ordering _Ordering forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b prism' (\() -> Ordering EQ) (\case Ordering EQ -> forall a. a -> Maybe a Just () Ordering _ -> forall a. Maybe a Nothing ) _GT :: Prism' a () _GT = forall a. IsOrdering a => Prism' a Ordering _Ordering forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b prism' (\() -> Ordering GT) (\case Ordering GT -> forall a. a -> Maybe a Just () Ordering _ -> forall a. Maybe a Nothing ) instance IsOrdering Ordering where _Ordering :: Prism' Ordering Ordering _Ordering = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a id instance IsOrdering (Maybe Bool) where _Ordering :: Prism' (Maybe Bool) Ordering _Ordering = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b iso (\case Maybe Bool Nothing -> Ordering LT Just Bool False -> Ordering EQ Just Bool True -> Ordering GT ) (\case Ordering LT -> forall a. Maybe a Nothing Ordering EQ -> forall a. a -> Maybe a Just Bool False Ordering GT -> forall a. a -> Maybe a Just Bool True ) class IsOrdering a => IsOrderingKnownEq a where _OrderingKnownEq :: Prism' a OrderingKnownEq _KnownEQ :: Prism' a () _KnownEQ = forall a. IsOrderingKnownEq a => Prism' a OrderingKnownEq _OrderingKnownEq forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b prism' (\() -> forall a. Maybe a Nothing) (\case OrderingKnownEq Nothing -> forall a. a -> Maybe a Just () OrderingKnownEq _ -> forall a. Maybe a Nothing ) instance IsOrdering OrderingKnownEq where _Ordering :: Prism' OrderingKnownEq Ordering _Ordering = forall a b. Prism (Maybe a) (Maybe b) a b _Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall a. IsOrdering a => Prism' a Ordering _Ordering instance IsOrderingKnownEq OrderingKnownEq where _OrderingKnownEq :: Prism' OrderingKnownEq OrderingKnownEq _OrderingKnownEq = forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a id order :: Iso (Order b a) (Order b' a') (a -> a -> b) (a' -> a' -> b') order :: forall b a b' a'. Iso (Order b a) (Order b' a') (a -> a -> b) (a' -> a' -> b') order = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b iso (\(Order a -> a -> b x) -> a -> a -> b x) forall b a. (a -> a -> b) -> Order b a Order instance Semigroup b => Semigroup (Order b a) where Order a -> a -> b f <> :: Order b a -> Order b a -> Order b a <> Order a -> a -> b g = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> a -> a -> b f a a1 a a2 forall a. Semigroup a => a -> a -> a <> a -> a -> b g a a1 a a2) instance Monoid b => Monoid (Order b a) where mempty :: Order b a mempty = forall b a. (a -> a -> b) -> Order b a Order (\a _ a _ -> forall a. Monoid a => a mempty) instance Contravariant (Order b) where contramap :: forall a' a. (a' -> a) -> Order b a -> Order b a' contramap a' -> a f (Order a -> a -> b g) = forall b a. (a -> a -> b) -> Order b a Order (\a' a1 a' a2 -> a -> a -> b g (a' -> a f a' a1) (a' -> a f a' a2)) instance Monoid b => Divisible (Order b) where divide :: forall a b c. (a -> (b, c)) -> Order b b -> Order b c -> Order b a divide a -> (b, c) f (Order b -> b -> b g) (Order c -> c -> b h) = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> let (b b1, c c1) = a -> (b, c) f a a1 (b b2, c c2) = a -> (b, c) f a a2 in b -> b -> b g b b1 b b2 forall a. Semigroup a => a -> a -> a <> c -> c -> b h c c1 c c2) conquer :: forall a. Order b a conquer = forall b a. (a -> a -> b) -> Order b a Order (\a _ a _ -> forall a. Monoid a => a mempty) instance Monoid b => Decidable (Order b) where choose :: forall a b c. (a -> Either b c) -> Order b b -> Order b c -> Order b a choose a -> Either b c f (Order b -> b -> b g) (Order c -> c -> b h) = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> let e1 :: Either b c e1 = a -> Either b c f a a1 e2 :: Either b c e2 = a -> Either b c f a a2 in forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either b -> b -> b g (\c _ b _ -> forall a. Monoid a => a mempty) Either b c e2) (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (\b _ c _ -> forall a. Monoid a => a mempty) c -> c -> b h Either b c e2) Either b c e1) lose :: forall a. (a -> Void) -> Order b a lose a -> Void f = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> forall a. Void -> a absurd (a -> Void f a a1 forall a. Semigroup a => a -> a -> a <> a -> Void f a a2)) lt :: IsOrdering b => Order b a lt :: forall b a. IsOrdering b => Order b a lt = forall b a. (a -> a -> b) -> Order b a Order (\a _ a _ -> forall a. IsOrdering a => Prism' a () _LT forall t b. AReview t b -> b -> t # ()) isLT :: IsOrdering b => Order b a -> a -> a -> Bool isLT :: forall b a. IsOrdering b => Order b a -> a -> a -> Bool isLT (Order a -> a -> b f) a a1 a a2 = Bool -> Bool not (forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrdering a => Prism' a () _LT (a -> a -> b f a a1 a a2)) ifLT :: IsOrdering x => a -> a -> x -> a ifLT :: forall x a. IsOrdering x => a -> a -> x -> a ifLT a a1 a a2 = forall a. a -> a -> Bool -> a bool a a2 a a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . Bool -> Bool not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrdering a => Prism' a () _LT eq :: IsOrdering b => Order b a eq :: forall b a. IsOrdering b => Order b a eq = forall b a. (a -> a -> b) -> Order b a Order (\a _ a _ -> forall a. IsOrdering a => Prism' a () _EQ forall t b. AReview t b -> b -> t # ()) isEQ :: IsOrdering b => Order b a -> a -> a -> Bool isEQ :: forall b a. IsOrdering b => Order b a -> a -> a -> Bool isEQ (Order a -> a -> b f) a a1 a a2 = Bool -> Bool not (forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrdering a => Prism' a () _EQ (a -> a -> b f a a1 a a2)) ifEQ :: IsOrdering x => a -> a -> x -> a ifEQ :: forall x a. IsOrdering x => a -> a -> x -> a ifEQ a a1 a a2 = forall a. a -> a -> Bool -> a bool a a2 a a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . Bool -> Bool not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrdering a => Prism' a () _EQ gt :: IsOrdering b => Order b a gt :: forall b a. IsOrdering b => Order b a gt = forall b a. (a -> a -> b) -> Order b a Order (\a _ a _ -> forall a. IsOrdering a => Prism' a () _GT forall t b. AReview t b -> b -> t # ()) isGT :: IsOrdering b => Order b a -> a -> a -> Bool isGT :: forall b a. IsOrdering b => Order b a -> a -> a -> Bool isGT (Order a -> a -> b f) a a1 a a2 = Bool -> Bool not (forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrdering a => Prism' a () _GT (a -> a -> b f a a1 a a2)) ifGT :: IsOrdering x => a -> a -> x -> a ifGT :: forall x a. IsOrdering x => a -> a -> x -> a ifGT a a1 a a2 = forall a. a -> a -> Bool -> a bool a a2 a a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . Bool -> Bool not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrdering a => Prism' a () _GT knownEq :: IsOrderingKnownEq b => Order b a knownEq :: forall b a. IsOrderingKnownEq b => Order b a knownEq = forall b a. (a -> a -> b) -> Order b a Order (\a _ a _ -> forall a. IsOrderingKnownEq a => Prism' a () _KnownEQ forall t b. AReview t b -> b -> t # ()) isKnownEq :: IsOrderingKnownEq b => Order b a -> a -> a -> Bool isKnownEq :: forall b a. IsOrderingKnownEq b => Order b a -> a -> a -> Bool isKnownEq (Order a -> a -> b f) a a1 a a2 = Bool -> Bool not (forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrderingKnownEq a => Prism' a () _KnownEQ (a -> a -> b f a a1 a a2)) ifKnownEq :: IsOrderingKnownEq x => a -> a -> x -> a ifKnownEq :: forall x a. IsOrderingKnownEq x => a -> a -> x -> a ifKnownEq a a1 a a2 = forall a. a -> a -> Bool -> a bool a a2 a a1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . Bool -> Bool not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall s t a b. APrism s t a b -> s -> Bool isn't forall a. IsOrderingKnownEq a => Prism' a () _KnownEQ ordOrder :: (Ord a, IsOrdering b) => Order b a ordOrder :: forall a b. (Ord a, IsOrdering b) => Order b a ordOrder = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> case forall a. Ord a => a -> a -> Ordering compare a a1 a a2 of Ordering LT -> forall a. IsOrdering a => Prism' a () _LT forall t b. AReview t b -> b -> t # () Ordering GT -> forall a. IsOrdering a => Prism' a () _GT forall t b. AReview t b -> b -> t # () Ordering EQ -> forall a. IsOrdering a => Prism' a () _EQ forall t b. AReview t b -> b -> t # ()) knownUnknownOrdering :: (IsOrderingKnownEq t, IsOrderingKnownEq a) => t -> a knownUnknownOrdering :: forall t a. (IsOrderingKnownEq t, IsOrderingKnownEq a) => t -> a knownUnknownOrdering t x = forall x a. IsOrdering x => a -> a -> x -> a ifEQ (forall a. IsOrderingKnownEq a => Prism' a () _KnownEQ forall t b. AReview t b -> b -> t # ()) ( forall x a. IsOrderingKnownEq x => a -> a -> x -> a ifKnownEq (forall a. IsOrdering a => Prism' a () _EQ forall t b. AReview t b -> b -> t # ()) ( forall x a. IsOrdering x => a -> a -> x -> a ifLT (forall a. IsOrdering a => Prism' a () _LT forall t b. AReview t b -> b -> t # ()) (forall a. IsOrdering a => Prism' a () _GT forall t b. AReview t b -> b -> t # ()) t x ) t x ) t x mapOrdering :: (b -> b') -> Order b a -> Order b' a mapOrdering :: forall b b' a. (b -> b') -> Order b a -> Order b' a mapOrdering b -> b' f (Order a -> a -> b g) = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> b -> b' f (a -> a -> b g a a1 a a2)) knownUnknownOrder :: IsOrderingKnownEq b => Order b a -> Order b a knownUnknownOrder :: forall b a. IsOrderingKnownEq b => Order b a -> Order b a knownUnknownOrder = forall b b' a. (b -> b') -> Order b a -> Order b' a mapOrdering forall t a. (IsOrderingKnownEq t, IsOrderingKnownEq a) => t -> a knownUnknownOrdering (*>>) :: Applicative f => Order (f a1) a2 -> Order (f b) a2 -> Order (f b) a2 *>> :: forall (f :: * -> *) a1 a2 b. Applicative f => Order (f a1) a2 -> Order (f b) a2 -> Order (f b) a2 (*>>) (Order a2 -> a2 -> f a1 f) (Order a2 -> a2 -> f b g) = forall b a. (a -> a -> b) -> Order b a Order (\a2 a1 a2 a2 -> a2 -> a2 -> f a1 f a2 a1 a2 a2 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> a2 -> a2 -> f b g a2 a1 a2 a2) infixr 6 *>> appendOrder :: Semigroup x => Order x x appendOrder :: forall x. Semigroup x => Order x x appendOrder = forall b a. (a -> a -> b) -> Order b a Order forall a. Semigroup a => a -> a -> a (<>) listOrder :: (IsOrdering b, Semigroup b) => Order b a -> Order b [a] listOrder :: forall b a. (IsOrdering b, Semigroup b) => Order b a -> Order b [a] listOrder (Order a -> a -> b f) = let lists :: [a] -> [a] -> b lists [] [] = forall a. IsOrdering a => Prism' a () _EQ forall t b. AReview t b -> b -> t # () lists [] (a _:[a] _) = forall a. IsOrdering a => Prism' a () _LT forall t b. AReview t b -> b -> t # () lists (a _:[a] _) [] = forall a. IsOrdering a => Prism' a () _GT forall t b. AReview t b -> b -> t # () lists (a h1:[a] t1) (a h2:[a] t2) = a -> a -> b f a h1 a h2 forall a. Semigroup a => a -> a -> a <> [a] -> [a] -> b lists [a] t1 [a] t2 in forall b a. (a -> a -> b) -> Order b a Order [a] -> [a] -> b lists orderL :: Contravariant f => Getting a s a -> f a -> f s orderL :: forall (f :: * -> *) a s. Contravariant f => Getting a s a -> f a -> f s orderL = forall (f :: * -> *) a' a. Contravariant f => (a' -> a) -> f a -> f a' contramap forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a view orderL' :: (Ord a, IsOrdering b) => Getting a s a -> Order b s orderL' :: forall a b s. (Ord a, IsOrdering b) => Getting a s a -> Order b s orderL' Getting a s a x = forall (f :: * -> *) a s. Contravariant f => Getting a s a -> f a -> f s orderL Getting a s a x forall a b. (Ord a, IsOrdering b) => Order b a ordOrder orderS :: Contravariant f => StateT a Identity b -> f b -> f a orderS :: forall (f :: * -> *) a b. Contravariant f => StateT a Identity b -> f b -> f a orderS StateT a Identity b x = forall (f :: * -> *) a' a. Contravariant f => (a' -> a) -> f a -> f a' contramap (forall a. Identity a -> a runIdentity forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a evalStateT StateT a Identity b x) orderS' :: (Ord x, IsOrdering b) => StateT a Identity x -> Order b a orderS' :: forall x b a. (Ord x, IsOrdering b) => StateT a Identity x -> Order b a orderS' StateT a Identity x x = forall (f :: * -> *) a b. Contravariant f => StateT a Identity b -> f b -> f a orderS StateT a Identity x x forall a b. (Ord a, IsOrdering b) => Order b a ordOrder duplicates :: KnownEqOrd OrderingKnownEq a => (t -> a) -> [t] -> [(t, t)] duplicates :: forall a t. KnownEqOrd OrderingKnownEq a => (t -> a) -> [t] -> [(t, t)] duplicates t -> a ord [t] t = let isEQ' :: Order OrderingKnownEq a -> a -> a -> Bool isEQ' :: forall a. Order OrderingKnownEq a -> a -> a -> Bool isEQ' = forall b a. IsOrdering b => Order b a -> a -> a -> Bool isEQ pairs :: [a] -> [(a, a)] pairs :: forall a. [a] -> [(a, a)] pairs [] = [] pairs (a h:[a] r) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (a h,) [a] r forall a. Semigroup a => a -> a -> a <> forall a. [a] -> [(a, a)] pairs [a] r in forall a. (a -> Bool) -> [a] -> [a] filter (\(t t1, t t2) -> forall a. Order OrderingKnownEq a -> a -> a -> Bool isEQ' forall b a. KnownEqOrd b a => Order b a knownEqCompare (t -> a ord t t1) (t -> a ord t t2)) (forall a. [a] -> [(a, a)] pairs [t] t) class Ord a => KnownEqOrd b a where knownEqCompare :: Order b a areEqual :: (Eq a, IsOrdering b) => a -> a -> Order b a -> Order b a areEqual :: forall a b. (Eq a, IsOrdering b) => a -> a -> Order b a -> Order b a areEqual a a1' a a2' (Order a -> a -> b f) = forall b a. (a -> a -> b) -> Order b a Order (\a a1 a a2 -> forall a. a -> a -> Bool -> a bool (a -> a -> b f a a1' a a2') (forall a. IsOrdering a => Prism' a () _EQ forall t b. AReview t b -> b -> t # ()) ((a a1 forall a. Eq a => a -> a -> Bool == a a1' Bool -> Bool -> Bool && a a2 forall a. Eq a => a -> a -> Bool == a a2') Bool -> Bool -> Bool || (a a1 forall a. Eq a => a -> a -> Bool == a a2' Bool -> Bool -> Bool && a a2 forall a. Eq a => a -> a -> Bool == a a1'))) (.===.) :: (Ord a, IsOrdering b) => a -> a -> Order b a a a1 .===. :: forall a b. (Ord a, IsOrdering b) => a -> a -> Order b a .===. a a2 = forall a b. (Eq a, IsOrdering b) => a -> a -> Order b a -> Order b a areEqual a a1 a a2 forall a b. (Ord a, IsOrdering b) => Order b a ordOrder