{-# 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 #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Order (
Order,
Total,
Preorder (..),
pcomparing,
Base (..),
N5 (..),
Ordering (..),
Down (..),
) 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.ExtendedReal
import safe Data.Fixed
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.Time.Clock.System
import safe Data.Void
import safe Data.Word
import safe GHC.Real
import safe Numeric.Natural
import safe Prelude hiding (Bounded, Ord (..), until)
type Order a = (Eq.Eq a, Preorder a)
type Total a = (Ord.Ord a, Preorder a)
class Preorder a where
{-# MINIMAL (<~) | pcompare #-}
infix 4 <~, >~, ?~, ~~, /~, `plt`, `pgt`, `pmax`, `pmin`, `pcompare`
(<~) :: a -> a -> Bool
x <~ y = maybe False (Ord.<= EQ) (pcompare x y)
(>~) :: a -> a -> Bool
(>~) = flip (<~)
(?~) :: a -> a -> Bool
x ?~ y = maybe False (const True) (pcompare x y)
(~~) :: a -> a -> Bool
x ~~ y = maybe False (Eq.== EQ) (pcompare x y)
(/~) :: a -> a -> Bool
x /~ y = not $ x ~~ y
plt :: a -> a -> Bool
plt x y = maybe False (Ord.< EQ) (pcompare x y)
pgt :: a -> a -> Bool
pgt = flip plt
similar :: a -> a -> Bool
similar x y = maybe True (Eq.== EQ) (pcompare x y)
pmax :: a -> a -> Maybe a
pmax x y = do
o <- pcompare x y
case o of
GT -> Just x
EQ -> Just x
LT -> Just y
pmin :: a -> a -> Maybe a
pmin x y = do
o <- pcompare x y
case o of
GT -> Just y
EQ -> Just x
LT -> Just x
pcompare :: a -> a -> Maybe Ordering
pcompare x y
| x <~ y = Just $ if y <~ x then EQ else LT
| y <~ x = Just GT
| otherwise = Nothing
pcomparing :: Preorder a => (b -> a) -> b -> b -> Maybe Ordering
pcomparing p x y = pcompare (p x) (p y)
newtype Base a = Base {getBase :: a}
deriving stock (Eq.Eq, Ord.Ord, Show, Functor)
deriving (Applicative) via Identity
instance Ord.Ord a => Preorder (Base a) where
x <~ y = getBase $ liftA2 (Ord.<=) x y
x >~ y = getBase $ liftA2 (Ord.>=) x y
pcompare x y = Just . getBase $ liftA2 Ord.compare x y
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
deriving via (Base (Fixed e)) instance Preorder (Fixed e)
newtype N5 a = N5 {getN5 :: a}
deriving stock (Eq, Show, Functor)
deriving (Applicative) via Identity
instance (Ord.Ord a, Fractional a) => Preorder (N5 a) where
x <~ y = getN5 $ liftA2 n5Le x y
n5Le :: (Ord.Ord a, Fractional a) => a -> a -> Bool
n5Le x y
| x Eq./= x && y Eq./= y = True
| x Eq./= x = y == 1 / 0
| y Eq./= y = x == -1 / 0
| otherwise = x Ord.<= y
deriving via (N5 Float) instance Preorder Float
deriving via (N5 Double) instance Preorder Double
pcompareRat :: Rational -> Rational -> Maybe Ordering
pcompareRat (0 :% 0) (x :% 0) = Just $ Ord.compare 0 x
pcompareRat (x :% 0) (0 :% 0) = Just $ Ord.compare x 0
pcompareRat (x :% 0) (y :% 0) = Just $ Ord.compare (signum x) (signum y)
pcompareRat (0 :% 0) _ = Nothing
pcompareRat _ (0 :% 0) = Nothing
pcompareRat _ (x :% 0) = Just $ Ord.compare 0 x
pcompareRat (x :% 0) _ = Just $ Ord.compare x 0
pcompareRat x y = Just $ Ord.compare x y
instance Preorder Rational where
pcompare = pcompareRat
instance Preorder SystemTime where
pcompare = fmap Just . compareSys
compareSys :: SystemTime -> SystemTime -> Ordering
compareSys (norm -> MkSystemTime xs xn) (norm -> MkSystemTime ys yn)
| EQ == os = Ord.compare xn yn
| otherwise = os
where
os = Ord.compare xs ys
s2ns :: Num a => a
s2ns = 10 ^ 9
norm :: SystemTime -> SystemTime
norm (MkSystemTime xs xn)
| xn Ord.>= s2ns = MkSystemTime (xs + q) (fromIntegral r)
| otherwise = MkSystemTime xs xn
where
(q, r) = fromIntegral xn `divMod` s2ns
instance (Preorder a, Num a) => Preorder (Complex a) where
pcompare = pcomparing $ \(x :+ y) -> x * x + y * y
instance Preorder a => Preorder (Down a) where
(Down x) <~ (Down y) = y <~ x
pcompare (Down x) (Down y) = pcompare y x
instance Preorder a => Preorder (Dual a) where
(Dual x) <~ (Dual y) = y <~ x
pcompare (Dual x) (Dual y) = pcompare y x
instance Preorder a => Preorder (Max a) where
Max a <~ Max b = a <~ b
instance Preorder a => Preorder (Min a) where
Min a <~ Min b = a <~ b
instance Preorder Any where
Any x <~ Any y = x <~ y
instance Preorder All where
All x <~ All y = y <~ x
instance Preorder a => Preorder (Identity a) where
pcompare (Identity x) (Identity y) = pcompare x y
instance Preorder a => Preorder (Maybe a) where
Nothing <~ _ = True
Just{} <~ Nothing = False
Just a <~ Just b = a <~ b
instance Preorder a => Preorder [a] where
{-# SPECIALIZE instance Preorder [Char] #-}
pcompare [] [] = Just EQ
pcompare [] (_ : _) = Just LT
pcompare (_ : _) [] = Just GT
pcompare (x : xs) (y : ys) = case pcompare x y of
Just EQ -> pcompare xs ys
other -> other
instance Preorder a => Preorder (NonEmpty a) where
(x :| xs) <~ (y :| ys) = x <~ y && xs <~ ys
instance Preorder a => Preorder (Extended a) where
_ <~ PosInf = True
PosInf <~ _ = False
NegInf <~ _ = True
_ <~ NegInf = False
Finite x <~ Finite y = x <~ y
instance (Preorder a, Preorder b) => Preorder (Either a b) where
Right a <~ Right b = a <~ b
Right _ <~ _ = False
Left a <~ Left b = a <~ b
Left _ <~ _ = True
instance (Preorder a, Preorder b) => Preorder (a, b) where
(a, b) <~ (i, j) = a <~ i && b <~ j
instance (Preorder a, Preorder b, Preorder c) => Preorder (a, b, c) where
(a, b, c) <~ (i, j, k) = a <~ i && b <~ j && c <~ k
instance (Preorder a, Preorder b, Preorder c, Preorder d) => Preorder (a, b, c, d) where
(a, b, c, d) <~ (i, j, k, l) = a <~ i && b <~ j && c <~ k && d <~ l
instance (Preorder a, Preorder b, Preorder c, Preorder d, Preorder e) => Preorder (a, b, c, d, e) where
(a, b, c, d, e) <~ (i, j, k, l, m) = a <~ i && b <~ j && c <~ k && d <~ l && e <~ m
instance (Ord.Ord k, Preorder a) => Preorder (Map.Map k a) where
(<~) = Map.isSubmapOfBy (<~)
instance Ord.Ord a => Preorder (Set.Set a) where
(<~) = Set.isSubsetOf
instance Preorder a => Preorder (IntMap.IntMap a) where
(<~) = IntMap.isSubmapOfBy (<~)
instance Preorder IntSet.IntSet where
(<~) = IntSet.isSubsetOf