linear-base-0.2.0: src/Data/Ord/Linear/Internal/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.Monoid.Linear
import Data.Ord (Ordering (..))
import Data.Ord.Linear.Internal.Eq
import Data.Unrestricted.Linear
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) =
    compare x y & \case
      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

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