{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Data.Order (
    -- * Constraint kinds
    Order,
    Total,

    -- * Preorders
    Preorder (..),
    pcomparing,

    -- * DerivingVia
    Base (..),
    N5 (..),

    -- * Re-exports
    Ordering (..),
    Down (..),
    Positive,
) where

import safe Control.Applicative
import safe Data.Bool
import safe Data.Complex
import safe Data.Either
import safe qualified Data.Eq as Eq
import safe Data.Functor.Identity
import safe Data.Int
import safe qualified Data.IntMap as IntMap
import safe qualified Data.IntSet as IntSet
import safe Data.List.NonEmpty
import safe qualified Data.Map as Map
import safe Data.Maybe
import safe Data.Ord (Down (..))
import safe qualified Data.Ord as Ord
import safe Data.Semigroup
import safe qualified Data.Set as Set
import safe Data.Void
import safe Data.Word
import safe GHC.Real
import safe Numeric.Natural
import safe Prelude hiding (Bounded, Ord (..), until)

-- | An < https://en.wikipedia.org/wiki/Order_theory#Partially_ordered_sets order > on /a/.
--
-- Note: ideally this would be a subclass of /Preorder/.
--
-- We instead use a constraint kind in order to retain compatibility with the
-- downstream users of /Eq/.
type Order a = (Eq.Eq a, Preorder a)

-- | A < https://en.wikipedia.org/wiki/Total_order total order > on /a/.
--
-- Note: ideally this would be a subclass of /Order/, without instances
-- for /Float/, /Double/, /Rational/, etc.
--
-- We instead use a constraint kind in order to retain compatibility with the
-- downstream users of /Ord/.
type Total a = (Ord.Ord a, Preorder a)

-------------------------------------------------------------------------------
-- Preorders
-------------------------------------------------------------------------------

-- | A < https://en.wikipedia.org/wiki/Preorder preorder > on /a/.
--
-- A preorder relation '<~' must satisfy the following two axioms:
--
-- \( \forall x: x \leq x \) (reflexivity)
--
-- \( \forall a, b, c: ((a \leq b) \wedge (b \leq c)) \Rightarrow (a \leq c) \) (transitivity)
--
-- Given a preorder on /a/ one may define an equivalence relation '~~' such that
-- /a ~~ b/ if and only if /a <~ b/ and /b <~ a/.
--
-- If no partion induced by '~~' contains more than a single element, then /a/
-- is a partial order and we may define an 'Eq' instance such that the
-- following holds:
--
-- @
-- x '==' y = x '~~' y
-- x '<=' y = x '<' y '||' x '~~' y
-- @
--
-- Minimal complete definition: either 'pcompare' or '<~'. Using 'pcompare' can
-- be more efficient for complex types.
class Preorder a where
    {-# MINIMAL (<~) | pcompare #-}

    infix 4 <~, >~, ?~, ~~, /~, `plt`, `pgt`, `pmax`, `pmin`, `pcompare`

    -- | A non-strict preorder order relation on /a/.
    --
    -- Is /x/ less than or equal to /y/?
    --
    -- '<~' is reflexive, anti-symmetric, and transitive.
    --
    -- > x <~ y = x < y || x ~~ y
    -- > x <~ y = maybe False (<~ EQ) (pcompare x y)
    --
    -- for all /x/, /y/ in /a/.
    (<~) :: a -> a -> Bool
    a
x <~ a
y = Bool -> (Ordering -> Bool) -> Maybe Ordering -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Ordering -> Ordering -> Bool
forall a. Ord a => a -> a -> Bool
Ord.<= Ordering
EQ) (a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y)

    -- | A converse non-strict preorder relation on /a/.
    --
    -- Is /x/ greater than or equal to /y/?
    --
    -- '>~' is reflexive, anti-symmetric, and transitive.
    --
    -- > x >~ y = x > y || x ~~ y
    -- > x >~ y = maybe False (>~ EQ) (pcompare x y)
    --
    -- for all /x/, /y/ in /a/.
    (>~) :: a -> a -> Bool
    (>~) = (a -> a -> Bool) -> a -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
(<~)

    -- | An equivalence relation on /a/.
    --
    -- Are /x/ and /y/ comparable?
    --
    -- '?~' is reflexive, symmetric, and transitive.
    --
    -- If /a/ implements 'Ord' then we should have @x ?~ y = True@.
    (?~) :: a -> a -> Bool
    a
x ?~ a
y = Bool -> (Ordering -> Bool) -> Maybe Ordering -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Ordering -> Bool
forall a b. a -> b -> a
const Bool
True) (a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y)

    -- | An equivalence relation on /a/.
    --
    -- Are /x/ and /y/ equivalent?
    --
    -- '~~' is reflexive, symmetric, and transitive.
    --
    -- > x ~~ y = x <~ y && y <~ x
    -- > x ~~ y = maybe False (~~ EQ) (pcompare x y)
    --
    -- Use this as a lawful substitute for '==' when comparing
    -- floats, doubles, or rationals.
    (~~) :: a -> a -> Bool
    a
x ~~ a
y = Bool -> (Ordering -> Bool) -> Maybe Ordering -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
Eq.== Ordering
EQ) (a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y)

    -- | Negation of '~~'.
    --
    -- Are /x/ and /y/ not equivalent?
    (/~) :: a -> a -> Bool
    a
x /~ a
y = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
~~ a
y

    -- | A strict preorder relation on /a/.
    --
    -- Is /x/ less than /y/?
    --
    -- 'plt' is irreflexive, asymmetric, and transitive.
    --
    -- > x `plt` y = x <~ y && not (y <~ x)
    -- > x `plt` y = maybe False (< EQ) (pcompare x y)
    --
    -- When '<~' is antisymmetric then /a/ is a partial
    -- order and we have:
    --
    -- > x `plt` y = x <~ y && x /~ y
    --
    -- for all /x/, /y/ in /a/.
    plt :: a -> a -> Bool
    plt a
x a
y = Bool -> (Ordering -> Bool) -> Maybe Ordering -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Ordering -> Ordering -> Bool
forall a. Ord a => a -> a -> Bool
Ord.< Ordering
EQ) (a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y)

    -- | A converse strict preorder relation on /a/.
    --
    -- Is /x/ greater than /y/?
    --
    -- 'pgt' is irreflexive, asymmetric, and transitive.
    --
    -- > x `pgt` y = x >~ y && not (y >~ x)
    -- > x `pgt` y = maybe False (> EQ) (pcompare x y)
    --
    -- When '<~' is antisymmetric then /a/ is a partial
    -- order and we have:
    --
    -- > x `pgt` y = x >~ y && x /~ y
    --
    -- for all /x/, /y/ in /a/.
    pgt :: a -> a -> Bool
    pgt = (a -> a -> Bool) -> a -> a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
plt

    -- | A similarity relation on /a/.
    --
    -- Are /x/ and /y/ either equivalent or incomparable?
    --
    -- 'similar' is reflexive and symmetric, but not necessarily transitive.
    --
    -- Note this is only equivalent to '==' in a total order:
    --
    -- > similar (0/0 :: Float) 5 = True
    --
    -- If /a/ implements 'Ord' then we should have @('~~') = 'similar' = ('==')@.
    similar :: a -> a -> Bool
    similar a
x a
y = Bool -> (Ordering -> Bool) -> Maybe Ordering -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
Eq.== Ordering
EQ) (a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y)

    -- | A partial version of 'Data.Ord.max'.
    --
    -- Returns the left-hand argument in the case of equality.
    pmax :: a -> a -> Maybe a
    pmax a
x a
y = do
        Ordering
o <- a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y
        case Ordering
o of
            Ordering
GT -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            Ordering
EQ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            Ordering
LT -> a -> Maybe a
forall a. a -> Maybe a
Just a
y

    -- | A partial version of 'Data.Ord.min'.
    --
    -- Returns the left-hand argument in the case of equality.
    pmin :: a -> a -> Maybe a
    pmin a
x a
y = do
        Ordering
o <- a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y
        case Ordering
o of
            Ordering
GT -> a -> Maybe a
forall a. a -> Maybe a
Just a
y
            Ordering
EQ -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            Ordering
LT -> a -> Maybe a
forall a. a -> Maybe a
Just a
x

    -- | A partial version of 'Data.Ord.compare'.
    --
    -- > x <  y = maybe False (<  EQ) $ pcompare x y
    -- > x >  y = maybe False (>  EQ) $ pcompare x y
    -- > x <~ y = maybe False (<~ EQ) $ pcompare x y
    -- > x >~ y = maybe False (>~ EQ) $ pcompare x y
    -- > x ~~ y = maybe False (~~ EQ) $ pcompare x y
    -- > x ?~ y = maybe False (const True) $ pcompare x y
    -- > similar x y = maybe True (~~ EQ) $ pcompare x y
    --
    -- If /a/ implements 'Ord' then we should have @'pcompare' x y = 'Just' '$' 'compare' x y@.
    pcompare :: a -> a -> Maybe Ordering
    pcompare a
x a
y
        | a
x a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
y = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ if a
y a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
x then Ordering
EQ else Ordering
LT
        | a
y a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
x = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
GT
        | Bool
otherwise = Maybe Ordering
forall a. Maybe a
Nothing

-- | A partial version of 'Data.Order.Total.comparing'.
--
-- > pcomparing p x y = pcompare (p x) (p y)
--
-- The partial application /pcomparing f/ induces a lawful preorder for
-- any total function /f/.
pcomparing :: Preorder a => (b -> a) -> b -> b -> Maybe Ordering
pcomparing :: (b -> a) -> b -> b -> Maybe Ordering
pcomparing b -> a
p b
x b
y = a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare (b -> a
p b
x) (b -> a
p b
y)

---------------------------------------------------------------------
-- DerivingVia
---------------------------------------------------------------------

newtype Base a = Base {Base a -> a
getBase :: a}
    deriving stock (Base a -> Base a -> Bool
(Base a -> Base a -> Bool)
-> (Base a -> Base a -> Bool) -> Eq (Base a)
forall a. Eq a => Base a -> Base a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base a -> Base a -> Bool
$c/= :: forall a. Eq a => Base a -> Base a -> Bool
== :: Base a -> Base a -> Bool
$c== :: forall a. Eq a => Base a -> Base a -> Bool
Eq.Eq, Eq (Base a)
Eq (Base a)
-> (Base a -> Base a -> Ordering)
-> (Base a -> Base a -> Bool)
-> (Base a -> Base a -> Bool)
-> (Base a -> Base a -> Bool)
-> (Base a -> Base a -> Bool)
-> (Base a -> Base a -> Base a)
-> (Base a -> Base a -> Base a)
-> Ord (Base a)
Base a -> Base a -> Bool
Base a -> Base a -> Ordering
Base a -> Base a -> Base a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Base a)
forall a. Ord a => Base a -> Base a -> Bool
forall a. Ord a => Base a -> Base a -> Ordering
forall a. Ord a => Base a -> Base a -> Base a
min :: Base a -> Base a -> Base a
$cmin :: forall a. Ord a => Base a -> Base a -> Base a
max :: Base a -> Base a -> Base a
$cmax :: forall a. Ord a => Base a -> Base a -> Base a
>= :: Base a -> Base a -> Bool
$c>= :: forall a. Ord a => Base a -> Base a -> Bool
> :: Base a -> Base a -> Bool
$c> :: forall a. Ord a => Base a -> Base a -> Bool
<= :: Base a -> Base a -> Bool
$c<= :: forall a. Ord a => Base a -> Base a -> Bool
< :: Base a -> Base a -> Bool
$c< :: forall a. Ord a => Base a -> Base a -> Bool
compare :: Base a -> Base a -> Ordering
$ccompare :: forall a. Ord a => Base a -> Base a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Base a)
Ord.Ord, Int -> Base a -> ShowS
[Base a] -> ShowS
Base a -> String
(Int -> Base a -> ShowS)
-> (Base a -> String) -> ([Base a] -> ShowS) -> Show (Base a)
forall a. Show a => Int -> Base a -> ShowS
forall a. Show a => [Base a] -> ShowS
forall a. Show a => Base a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Base a] -> ShowS
$cshowList :: forall a. Show a => [Base a] -> ShowS
show :: Base a -> String
$cshow :: forall a. Show a => Base a -> String
showsPrec :: Int -> Base a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Base a -> ShowS
Show, a -> Base b -> Base a
(a -> b) -> Base a -> Base b
(forall a b. (a -> b) -> Base a -> Base b)
-> (forall a b. a -> Base b -> Base a) -> Functor Base
forall a b. a -> Base b -> Base a
forall a b. (a -> b) -> Base a -> Base b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Base b -> Base a
$c<$ :: forall a b. a -> Base b -> Base a
fmap :: (a -> b) -> Base a -> Base b
$cfmap :: forall a b. (a -> b) -> Base a -> Base b
Functor)
    deriving (Functor Base
a -> Base a
Functor Base
-> (forall a. a -> Base a)
-> (forall a b. Base (a -> b) -> Base a -> Base b)
-> (forall a b c. (a -> b -> c) -> Base a -> Base b -> Base c)
-> (forall a b. Base a -> Base b -> Base b)
-> (forall a b. Base a -> Base b -> Base a)
-> Applicative Base
Base a -> Base b -> Base b
Base a -> Base b -> Base a
Base (a -> b) -> Base a -> Base b
(a -> b -> c) -> Base a -> Base b -> Base c
forall a. a -> Base a
forall a b. Base a -> Base b -> Base a
forall a b. Base a -> Base b -> Base b
forall a b. Base (a -> b) -> Base a -> Base b
forall a b c. (a -> b -> c) -> Base a -> Base b -> Base c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Base a -> Base b -> Base a
$c<* :: forall a b. Base a -> Base b -> Base a
*> :: Base a -> Base b -> Base b
$c*> :: forall a b. Base a -> Base b -> Base b
liftA2 :: (a -> b -> c) -> Base a -> Base b -> Base c
$cliftA2 :: forall a b c. (a -> b -> c) -> Base a -> Base b -> Base c
<*> :: Base (a -> b) -> Base a -> Base b
$c<*> :: forall a b. Base (a -> b) -> Base a -> Base b
pure :: a -> Base a
$cpure :: forall a. a -> Base a
$cp1Applicative :: Functor Base
Applicative) via Identity

instance Ord.Ord a => Preorder (Base a) where
    Base a
x <~ :: Base a -> Base a -> Bool
<~ Base a
y = Base Bool -> Bool
forall a. Base a -> a
getBase (Base Bool -> Bool) -> Base Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> Base a -> Base a -> Base Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Ord.<=) Base a
x Base a
y
    Base a
x >~ :: Base a -> Base a -> Bool
>~ Base a
y = Base Bool -> Bool
forall a. Base a -> a
getBase (Base Bool -> Bool) -> Base Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> Base a -> Base a -> Base Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(Ord.>=) Base a
x Base a
y
    pcompare :: Base a -> Base a -> Maybe Ordering
pcompare Base a
x Base a
y = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering)
-> (Base Ordering -> Ordering) -> Base Ordering -> Maybe Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base Ordering -> Ordering
forall a. Base a -> a
getBase (Base Ordering -> Maybe Ordering)
-> Base Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ (a -> a -> Ordering) -> Base a -> Base a -> Base Ordering
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Base a
x Base a
y

--instance Preorder Void where  _ <~ _ = True
deriving via (Base Void) instance Preorder Void
deriving via (Base ()) instance Preorder ()
deriving via (Base Bool) instance Preorder Bool
deriving via (Base Ordering) instance Preorder Ordering
deriving via (Base Char) instance Preorder Char
deriving via (Base Word) instance Preorder Word
deriving via (Base Word8) instance Preorder Word8
deriving via (Base Word16) instance Preorder Word16
deriving via (Base Word32) instance Preorder Word32
deriving via (Base Word64) instance Preorder Word64
deriving via (Base Natural) instance Preorder Natural
deriving via (Base Int) instance Preorder Int
deriving via (Base Int8) instance Preorder Int8
deriving via (Base Int16) instance Preorder Int16
deriving via (Base Int32) instance Preorder Int32
deriving via (Base Int64) instance Preorder Int64
deriving via (Base Integer) instance Preorder Integer

--TODO move to Order and derive Preorder as well
newtype N5 a = N5 {N5 a -> a
getN5 :: a}
    deriving stock (N5 a -> N5 a -> Bool
(N5 a -> N5 a -> Bool) -> (N5 a -> N5 a -> Bool) -> Eq (N5 a)
forall a. Eq a => N5 a -> N5 a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: N5 a -> N5 a -> Bool
$c/= :: forall a. Eq a => N5 a -> N5 a -> Bool
== :: N5 a -> N5 a -> Bool
$c== :: forall a. Eq a => N5 a -> N5 a -> Bool
Eq, Int -> N5 a -> ShowS
[N5 a] -> ShowS
N5 a -> String
(Int -> N5 a -> ShowS)
-> (N5 a -> String) -> ([N5 a] -> ShowS) -> Show (N5 a)
forall a. Show a => Int -> N5 a -> ShowS
forall a. Show a => [N5 a] -> ShowS
forall a. Show a => N5 a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [N5 a] -> ShowS
$cshowList :: forall a. Show a => [N5 a] -> ShowS
show :: N5 a -> String
$cshow :: forall a. Show a => N5 a -> String
showsPrec :: Int -> N5 a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> N5 a -> ShowS
Show, a -> N5 b -> N5 a
(a -> b) -> N5 a -> N5 b
(forall a b. (a -> b) -> N5 a -> N5 b)
-> (forall a b. a -> N5 b -> N5 a) -> Functor N5
forall a b. a -> N5 b -> N5 a
forall a b. (a -> b) -> N5 a -> N5 b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> N5 b -> N5 a
$c<$ :: forall a b. a -> N5 b -> N5 a
fmap :: (a -> b) -> N5 a -> N5 b
$cfmap :: forall a b. (a -> b) -> N5 a -> N5 b
Functor)
    deriving (Functor N5
a -> N5 a
Functor N5
-> (forall a. a -> N5 a)
-> (forall a b. N5 (a -> b) -> N5 a -> N5 b)
-> (forall a b c. (a -> b -> c) -> N5 a -> N5 b -> N5 c)
-> (forall a b. N5 a -> N5 b -> N5 b)
-> (forall a b. N5 a -> N5 b -> N5 a)
-> Applicative N5
N5 a -> N5 b -> N5 b
N5 a -> N5 b -> N5 a
N5 (a -> b) -> N5 a -> N5 b
(a -> b -> c) -> N5 a -> N5 b -> N5 c
forall a. a -> N5 a
forall a b. N5 a -> N5 b -> N5 a
forall a b. N5 a -> N5 b -> N5 b
forall a b. N5 (a -> b) -> N5 a -> N5 b
forall a b c. (a -> b -> c) -> N5 a -> N5 b -> N5 c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: N5 a -> N5 b -> N5 a
$c<* :: forall a b. N5 a -> N5 b -> N5 a
*> :: N5 a -> N5 b -> N5 b
$c*> :: forall a b. N5 a -> N5 b -> N5 b
liftA2 :: (a -> b -> c) -> N5 a -> N5 b -> N5 c
$cliftA2 :: forall a b c. (a -> b -> c) -> N5 a -> N5 b -> N5 c
<*> :: N5 (a -> b) -> N5 a -> N5 b
$c<*> :: forall a b. N5 (a -> b) -> N5 a -> N5 b
pure :: a -> N5 a
$cpure :: forall a. a -> N5 a
$cp1Applicative :: Functor N5
Applicative) via Identity

instance (Ord.Ord a, Fractional a) => Preorder (N5 a) where
    N5 a
x <~ :: N5 a -> N5 a -> Bool
<~ N5 a
y = N5 Bool -> Bool
forall a. N5 a -> a
getN5 (N5 Bool -> Bool) -> N5 Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> N5 a -> N5 a -> N5 Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> Bool
forall a. (Ord a, Fractional a) => a -> a -> Bool
n5Le N5 a
x N5 a
y

-- N5 lattice ordering: NInf <= NaN <= PInf
n5Le :: (Ord.Ord a, Fractional a) => a -> a -> Bool
n5Le :: a -> a -> Bool
n5Le a
x a
y
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
Eq./= a
x Bool -> Bool -> Bool
&& a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
Eq./= a
y = Bool
True
    | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
Eq./= a
x = a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0
    | a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
Eq./= a
y = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== -a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0
    | Bool
otherwise = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
Ord.<= a
y

deriving via (N5 Float) instance Preorder Float
deriving via (N5 Double) instance Preorder Double

---------------------------------------------------------------------
-- Instances
---------------------------------------------------------------------

-- N5 lattice ordering: NInf <= NaN <= PInf
{-
pinf = 1 :% 0
ninf = (-1) :% 0
anan = 0 :% 0

λ> pcompareRat anan pinf
Just LT
λ> pcompareRat pinf anan
Just GT
λ> pcompareRat anan anan
Just EQ
λ> pcompareRat anan (3 :% 5)
Nothing
-}
pcompareRat :: Rational -> Rational -> Maybe Ordering
pcompareRat :: Rational -> Rational -> Maybe Ordering
pcompareRat (Integer
0 :% Integer
0) (Integer
x :% Integer
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Integer
0 Integer
x
pcompareRat (Integer
x :% Integer
0) (Integer
0 :% Integer
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Integer
x Integer
0
pcompareRat (Integer
x :% Integer
0) (Integer
y :% Integer
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare (Integer -> Integer
forall a. Num a => a -> a
signum Integer
x) (Integer -> Integer
forall a. Num a => a -> a
signum Integer
y)
pcompareRat (Integer
0 :% Integer
0) Rational
_ = Maybe Ordering
forall a. Maybe a
Nothing
pcompareRat Rational
_ (Integer
0 :% Integer
0) = Maybe Ordering
forall a. Maybe a
Nothing
pcompareRat Rational
_ (Integer
x :% Integer
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Integer
0 Integer
x -- guard against div-by-zero exceptions
pcompareRat (Integer
x :% Integer
0) Rational
_ = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Integer
x Integer
0
pcompareRat Rational
x Rational
y = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Rational
x Rational
y

-- | Positive rationals, extended with an absorbing zero.
--
-- 'Positive' is the canonical < https://en.wikipedia.org/wiki/Semifield#Examples semifield >.
type Positive = Ratio Natural

-- N5 lattice comparison
pcomparePos :: Positive -> Positive -> Maybe Ordering
pcomparePos :: Positive -> Positive -> Maybe Ordering
pcomparePos (Natural
0 :% Natural
0) (Natural
x :% Natural
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Natural
0 Natural
x
pcomparePos (Natural
x :% Natural
0) (Natural
0 :% Natural
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare Natural
x Natural
0
pcomparePos (Natural
_ :% Natural
0) (Natural
_ :% Natural
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
EQ -- all non-nan infs are equal
pcomparePos (Natural
0 :% Natural
0) (Natural
0 :% Natural
_) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Ordering
GT
pcomparePos (Natural
0 :% Natural
_) (Natural
0 :% Natural
0) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Ordering
LT
pcomparePos (Natural
0 :% Natural
0) Positive
_ = Maybe Ordering
forall a. Maybe a
Nothing
pcomparePos Positive
_ (Natural
0 :% Natural
0) = Maybe Ordering
forall a. Maybe a
Nothing
pcomparePos (Natural
x :% Natural
y) (Natural
x' :% Natural
y') = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just (Ordering -> Maybe Ordering) -> Ordering -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ Natural -> Natural -> Ordering
forall a. Ord a => a -> a -> Ordering
Ord.compare (Natural
x Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
y') (Natural
x' Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
y)

instance Preorder Rational where
    pcompare :: Rational -> Rational -> Maybe Ordering
pcompare = Rational -> Rational -> Maybe Ordering
pcompareRat

instance Preorder Positive where
    pcompare :: Positive -> Positive -> Maybe Ordering
pcompare = Positive -> Positive -> Maybe Ordering
pcomparePos

instance (Preorder a, Num a) => Preorder (Complex a) where
    pcompare :: Complex a -> Complex a -> Maybe Ordering
pcompare = (Complex a -> a) -> Complex a -> Complex a -> Maybe Ordering
forall a b. Preorder a => (b -> a) -> b -> b -> Maybe Ordering
pcomparing ((Complex a -> a) -> Complex a -> Complex a -> Maybe Ordering)
-> (Complex a -> a) -> Complex a -> Complex a -> Maybe Ordering
forall a b. (a -> b) -> a -> b
$ \(a
x :+ a
y) -> a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y a -> a -> a
forall a. Num a => a -> a -> a
* a
y

instance Preorder a => Preorder (Down a) where
    (Down a
x) <~ :: Down a -> Down a -> Bool
<~ (Down a
y) = a
y a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
x
    pcompare :: Down a -> Down a -> Maybe Ordering
pcompare (Down a
x) (Down a
y) = a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
y a
x

instance Preorder a => Preorder (Dual a) where
    (Dual a
x) <~ :: Dual a -> Dual a -> Bool
<~ (Dual a
y) = a
y a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
x
    pcompare :: Dual a -> Dual a -> Maybe Ordering
pcompare (Dual a
x) (Dual a
y) = a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
y a
x

instance Preorder a => Preorder (Max a) where
    Max a
a <~ :: Max a -> Max a -> Bool
<~ Max a
b = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
b

instance Preorder a => Preorder (Min a) where
    Min a
a <~ :: Min a -> Min a -> Bool
<~ Min a
b = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
b

instance Preorder Any where
    Any Bool
x <~ :: Any -> Any -> Bool
<~ Any Bool
y = Bool
x Bool -> Bool -> Bool
forall a. Preorder a => a -> a -> Bool
<~ Bool
y

instance Preorder All where
    All Bool
x <~ :: All -> All -> Bool
<~ All Bool
y = Bool
y Bool -> Bool -> Bool
forall a. Preorder a => a -> a -> Bool
<~ Bool
x

instance Preorder a => Preorder (Identity a) where
    pcompare :: Identity a -> Identity a -> Maybe Ordering
pcompare (Identity a
x) (Identity a
y) = a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y

instance Preorder a => Preorder (Maybe a) where
    Maybe a
Nothing <~ :: Maybe a -> Maybe a -> Bool
<~ Maybe a
_ = Bool
True
    Just{} <~ Maybe a
Nothing = Bool
False
    Just a
a <~ Just a
b = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
b

instance Preorder a => Preorder [a] where
    {-# SPECIALIZE instance Preorder [Char] #-}

    --[] <~ _     = True
    --(_:_) <~ [] = False
    --(x:xs) <~ (y:ys) = x <~ y && xs <~ ys

    pcompare :: [a] -> [a] -> Maybe Ordering
pcompare [] [] = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
EQ
    pcompare [] (a
_ : [a]
_) = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
LT
    pcompare (a
_ : [a]
_) [] = Ordering -> Maybe Ordering
forall a. a -> Maybe a
Just Ordering
GT
    pcompare (a
x : [a]
xs) (a
y : [a]
ys) = case a -> a -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare a
x a
y of
        Just Ordering
EQ -> [a] -> [a] -> Maybe Ordering
forall a. Preorder a => a -> a -> Maybe Ordering
pcompare [a]
xs [a]
ys
        Maybe Ordering
other -> Maybe Ordering
other

instance Preorder a => Preorder (NonEmpty a) where
    (a
x :| [a]
xs) <~ :: NonEmpty a -> NonEmpty a -> Bool
<~ (a
y :| [a]
ys) = a
x a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
y Bool -> Bool -> Bool
&& [a]
xs [a] -> [a] -> Bool
forall a. Preorder a => a -> a -> Bool
<~ [a]
ys

instance (Preorder a, Preorder b) => Preorder (Either a b) where
    Right b
a <~ :: Either a b -> Either a b -> Bool
<~ Right b
b = b
a b -> b -> Bool
forall a. Preorder a => a -> a -> Bool
<~ b
b
    Right b
_ <~ Either a b
_ = Bool
False
    Left a
a <~ Left a
b = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
b
    Left a
_ <~ Either a b
_ = Bool
True

instance (Preorder a, Preorder b) => Preorder (a, b) where
    (a
a, b
b) <~ :: (a, b) -> (a, b) -> Bool
<~ (a
i, b
j) = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
i Bool -> Bool -> Bool
&& b
b b -> b -> Bool
forall a. Preorder a => a -> a -> Bool
<~ b
j

instance (Preorder a, Preorder b, Preorder c) => Preorder (a, b, c) where
    (a
a, b
b, c
c) <~ :: (a, b, c) -> (a, b, c) -> Bool
<~ (a
i, b
j, c
k) = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
i Bool -> Bool -> Bool
&& b
b b -> b -> Bool
forall a. Preorder a => a -> a -> Bool
<~ b
j Bool -> Bool -> Bool
&& c
c c -> c -> Bool
forall a. Preorder a => a -> a -> Bool
<~ c
k

instance (Preorder a, Preorder b, Preorder c, Preorder d) => Preorder (a, b, c, d) where
    (a
a, b
b, c
c, d
d) <~ :: (a, b, c, d) -> (a, b, c, d) -> Bool
<~ (a
i, b
j, c
k, d
l) = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
i Bool -> Bool -> Bool
&& b
b b -> b -> Bool
forall a. Preorder a => a -> a -> Bool
<~ b
j Bool -> Bool -> Bool
&& c
c c -> c -> Bool
forall a. Preorder a => a -> a -> Bool
<~ c
k Bool -> Bool -> Bool
&& d
d d -> d -> Bool
forall a. Preorder a => a -> a -> Bool
<~ d
l

instance (Preorder a, Preorder b, Preorder c, Preorder d, Preorder e) => Preorder (a, b, c, d, e) where
    (a
a, b
b, c
c, d
d, e
e) <~ :: (a, b, c, d, e) -> (a, b, c, d, e) -> Bool
<~ (a
i, b
j, c
k, d
l, e
m) = a
a a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
<~ a
i Bool -> Bool -> Bool
&& b
b b -> b -> Bool
forall a. Preorder a => a -> a -> Bool
<~ b
j Bool -> Bool -> Bool
&& c
c c -> c -> Bool
forall a. Preorder a => a -> a -> Bool
<~ c
k Bool -> Bool -> Bool
&& d
d d -> d -> Bool
forall a. Preorder a => a -> a -> Bool
<~ d
l Bool -> Bool -> Bool
&& e
e e -> e -> Bool
forall a. Preorder a => a -> a -> Bool
<~ e
m

instance (Ord.Ord k, Preorder a) => Preorder (Map.Map k a) where
    <~ :: Map k a -> Map k a -> Bool
(<~) = (a -> a -> Bool) -> Map k a -> Map k a -> Bool
forall k a b.
Ord k =>
(a -> b -> Bool) -> Map k a -> Map k b -> Bool
Map.isSubmapOfBy a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
(<~)

instance Ord.Ord a => Preorder (Set.Set a) where
    <~ :: Set a -> Set a -> Bool
(<~) = Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf

instance Preorder a => Preorder (IntMap.IntMap a) where
    <~ :: IntMap a -> IntMap a -> Bool
(<~) = (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool
forall a b. (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
IntMap.isSubmapOfBy a -> a -> Bool
forall a. Preorder a => a -> a -> Bool
(<~)

instance Preorder IntSet.IntSet where
    <~ :: IntSet -> IntSet -> Bool
(<~) = IntSet -> IntSet -> Bool
IntSet.isSubsetOf