Ord.hs

{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK hide #-}

module Data.Ord.Linear.Internal.Ord
  ( Ord (..),
    Ordering (..),
    min,
    max,
  )
where

import Data.Bool.Linear (Bool (..), not)
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Monoid.Linear
import Data.Ord (Ordering (..))
import Data.Ord.Linear.Internal.Eq
import Data.Unrestricted.Linear
import Data.Word (Word16, Word32, Word64, Word8)
import Prelude.Linear.Internal
import qualified Prelude

-- | Linear Orderings
--
-- Linear orderings provide a strict order. The laws for @(<=)@ for
-- all \(a,b,c\):
--
-- * reflexivity: \(a \leq a \)
-- * antisymmetry: \((a \leq b) \land (b \leq a) \rightarrow (a = b) \)
-- * transitivity: \((a \leq b) \land (b \leq c) \rightarrow (a \leq c) \)
--
-- and these \"agree\" with @<@:
--
-- * @x <= y@ = @not (y > x)@
-- * @x >= y@ = @not (y < x)@
--
-- Unlike in the non-linear setting, a linear @compare@ doesn't follow from
-- @<=@ since it requires calls: one to @<=@ and one to @==@. However,
-- from a linear @compare@ it is easy to implement the others. Hence, the
-- minimal complete definition only contains @compare@.
class (Eq a) => Ord a where
  {-# MINIMAL compare #-}

  -- | @compare x y@ returns an @Ordering@ which is
  -- one of @GT@ (greater than), @EQ@ (equal), or @LT@ (less than)
  -- which should be understood as \"x is @(compare x y)@ y\".
  compare :: a %1 -> a %1 -> Ordering

  -- /!\ `compare` doesn't have a specified fixity in base
  -- but we chose infix 4 for consistency with `elem`, <, <=, ==, /= ...
  infix 4 `compare`

  (<=) :: a %1 -> a %1 -> Bool
  x <= y = not (x > y)
  infix 4 <= -- same fixity as base.<=

  (<) :: a %1 -> a %1 -> Bool
  x < y = compare x y == LT
  infix 4 < -- same fixity as base.<

  (>) :: a %1 -> a %1 -> Bool
  x > y = compare x y == GT
  infix 4 > -- same fixity as base.>

  (>=) :: a %1 -> a %1 -> Bool
  x >= y = not (x < y)
  infix 4 >= -- same fixity as base.>=

-- | @max x y@ returns the larger input, or  'y'
-- in case of a tie.
max :: (Dupable a, Ord a) => a %1 -> a %1 -> a
max x y =
  dup2 x & \(x', x'') ->
    dup2 y & \(y', y'') ->
      if x' <= y'
        then x'' `lseq` y''
        else y'' `lseq` x''

-- | @min x y@ returns the smaller input, or 'y'
-- in case of a tie.
min :: (Dupable a, Ord a) => a %1 -> a %1 -> a
min x y =
  dup2 x & \(x', x'') ->
    dup2 y & \(y', y'') ->
      if x' <= y'
        then y'' `lseq` x''
        else x'' `lseq` y''

-- * Instances

instance (Prelude.Ord a) => Ord (Ur a) where
  Ur x `compare` Ur y = x `Prelude.compare` y

instance (Consumable a, Ord a) => Ord (Prelude.Maybe a) where
  Prelude.Nothing `compare` Prelude.Nothing = EQ
  Prelude.Nothing `compare` Prelude.Just y = y `lseq` LT
  Prelude.Just x `compare` Prelude.Nothing = x `lseq` GT
  Prelude.Just x `compare` Prelude.Just y = x `compare` y

instance
  (Consumable a, Consumable b, Ord a, Ord b) =>
  Ord (Prelude.Either a b)
  where
  Prelude.Left x `compare` Prelude.Right y = (x, y) `lseq` LT
  Prelude.Right x `compare` Prelude.Left y = (x, y) `lseq` GT
  Prelude.Left x `compare` Prelude.Left y = x `compare` y
  Prelude.Right x `compare` Prelude.Right y = x `compare` y

instance (Consumable a, Ord a) => Ord [a] where
  {-# SPECIALIZE instance Ord [Prelude.Char] #-}
  compare [] [] = EQ
  compare xs [] = xs `lseq` GT
  compare [] ys = ys `lseq` LT
  compare (x : xs) (y : ys) =
    case compare x y of
      EQ -> compare xs ys
      res -> (xs, ys) `lseq` res

instance (Ord a, Ord b) => Ord (a, b) where
  (a, b) `compare` (a', b') =
    compare a a' <> compare b b'

instance (Ord a, Ord b, Ord c) => Ord (a, b, c) where
  (a, b, c) `compare` (a', b', c') =
    compare a a' <> compare b b' <> compare c c'

instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d) where
  (a, b, c, d) `compare` (a', b', c', d') =
    compare a a' <> compare b b' <> compare c c' <> compare d d'

deriving via MovableOrd () instance Ord ()

deriving via MovableOrd Prelude.Int instance Ord Prelude.Int

deriving via MovableOrd Prelude.Double instance Ord Prelude.Double

deriving via MovableOrd Prelude.Bool instance Ord Prelude.Bool

deriving via MovableOrd Prelude.Char instance Ord Prelude.Char

deriving via MovableOrd Prelude.Ordering instance Ord Prelude.Ordering

deriving via MovableOrd Int16 instance Ord Int16

deriving via MovableOrd Int32 instance Ord Int32

deriving via MovableOrd Int64 instance Ord Int64

deriving via MovableOrd Int8 instance Ord Int8

deriving via MovableOrd Word16 instance Ord Word16

deriving via MovableOrd Word32 instance Ord Word32

deriving via MovableOrd Word64 instance Ord Word64

deriving via MovableOrd Word8 instance Ord Word8

newtype MovableOrd a = MovableOrd a

instance (Prelude.Eq a, Movable a) => Eq (MovableOrd a) where
  MovableOrd ar == MovableOrd br =
    move (ar, br) & \(Ur (a, b)) ->
      a Prelude.== b

  MovableOrd ar /= MovableOrd br =
    move (ar, br) & \(Ur (a, b)) ->
      a Prelude./= b

instance (Prelude.Ord a, Movable a) => Ord (MovableOrd a) where
  MovableOrd ar `compare` MovableOrd br =
    move (ar, br) & \(Ur (a, b)) ->
      a `Prelude.compare` b