PartialOrder.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- | A partial order on a type, wrapping @a -> a -> 'Maybe' 'Ordering'@.
--
-- This is the partial order analogue of 'Data.Functor.Contravariant.Comparison'
-- (which represents total orders via @a -> a -> 'Ordering'@).
-- The 'Nothing' case represents incomparable elements.
--
-- @
-- 'Just' 'LT'  — a < b
-- 'Just' 'EQ'  — a = b
-- 'Just' 'GT'  — a > b
-- 'Nothing'  — a and b are incomparable
-- @
module Data.Valuation.PartialOrder
  ( PartialOrder (..),

    -- * optics
    HasPartialOrder (..),
    AsPartialOrder (..),
    isBinaryFunctionT,

    -- * combinators
    semigroupPartialOrder,
    runPartialOrder,
    partialOrderLeq,
    totalOrder,
    fromLeq,
  )
where

import Control.Lens
  ( Iso,
    Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    from,
    iso,
    review,
    _Wrapped,
  )
import Data.Functor.Contravariant (Contravariant (..))
import Data.Functor.Contravariant.Conclude (Conclude (..))
import Data.Functor.Contravariant.Decide (Decide (..))
import Data.Functor.Contravariant.Divise (Divise (..))
import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))
import Data.Valuation.BinaryFunction
  ( AsBinaryFunctionT (..),
    BinaryFunctionT,
    HasBinaryFunctionT (..),
  )
import Data.Valuation.Semigroup
  ( Semigroup,
    applySemigroup,
    runSemigroup,
  )
import Data.Void (absurd)
import Prelude hiding (Semigroup)
import qualified Prelude

-- $setup
-- >>> :set -Wno-name-shadowing -Wno-type-defaults
-- >>> import Data.Void (Void)

-- |
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 1 2
-- Just LT
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 2 2
-- Just EQ
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 3 2
-- Just GT
--
-- >>> import qualified Data.Set as Set
-- >>> runPartialOrder (fromLeq Set.isSubsetOf) (Set.fromList [1,2]) (Set.fromList [2,3 :: Int])
-- Nothing
newtype PartialOrder a
  = PartialOrder (a -> a -> Maybe Ordering)

instance (PartialOrder a ~ t) => Rewrapped (PartialOrder a') t

instance Wrapped (PartialOrder a) where
  type Unwrapped (PartialOrder a) = a -> a -> Maybe Ordering
  _Wrapped' = iso (\(PartialOrder x) -> x) PartialOrder

-- | Classy lens for types that contain a 'PartialOrder'.
class HasPartialOrder c a | c -> a where
  partialOrder :: Lens' c (PartialOrder a)

instance HasPartialOrder (PartialOrder a) a where
  partialOrder = id

-- | Classy prism for types that can be constructed from a 'PartialOrder'.
class AsPartialOrder c a | c -> a where
  _PartialOrder :: Prism' c (PartialOrder a)

instance AsPartialOrder (PartialOrder a) a where
  _PartialOrder = id

instance HasBinaryFunctionT (PartialOrder a) Maybe a Ordering where
  binaryFunctionT = isBinaryFunctionT

instance AsBinaryFunctionT (PartialOrder a) Maybe a Ordering where
  _BinaryFunctionT = isBinaryFunctionT

isBinaryFunctionT :: Iso (PartialOrder a) (PartialOrder a') (BinaryFunctionT Maybe a Ordering) (BinaryFunctionT Maybe a' Ordering)
isBinaryFunctionT = _Wrapped . from _Wrapped

-- | Apply the partial order comparison.
--
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 1 2
-- Just LT
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 2 2
-- Just EQ
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 3 2
-- Just GT
runPartialOrder :: PartialOrder a -> a -> a -> Maybe Ordering
runPartialOrder (PartialOrder f) = f

-- | Test whether @a <= b@ in the partial order.
-- Returns 'True' iff the comparison yields 'Just' 'LT' or 'Just' 'EQ'.
-- Returns 'False' for incomparable elements.
--
-- >>> partialOrderLeq (totalOrder :: PartialOrder Int) 1 2
-- True
-- >>> partialOrderLeq (totalOrder :: PartialOrder Int) 2 2
-- True
-- >>> partialOrderLeq (totalOrder :: PartialOrder Int) 3 2
-- False
--
-- >>> import qualified Data.Set as Set
-- >>> partialOrderLeq (fromLeq Set.isSubsetOf) (Set.fromList [1,2]) (Set.fromList [2,3 :: Int])
-- False
partialOrderLeq :: PartialOrder a -> a -> a -> Bool
partialOrderLeq po a b = case runPartialOrder po a b of
  Just LT -> True
  Just EQ -> True
  _ -> False

-- | Construct a 'PartialOrder' from a total order ('Ord' instance).
-- The result never yields 'Nothing' since all elements are comparable.
--
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 1 2
-- Just LT
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 2 2
-- Just EQ
-- >>> runPartialOrder (totalOrder :: PartialOrder Int) 3 2
-- Just GT
totalOrder :: (Ord a) => PartialOrder a
totalOrder = PartialOrder (\a b -> Just (compare a b))

-- | Construct a 'PartialOrder' from a less-than-or-equal predicate.
--
-- The predicate should satisfy the partial order laws
-- (reflexive, antisymmetric, transitive).
-- Elements where neither @leq a b@ nor @leq b a@ holds are incomparable ('Nothing').
--
-- >>> import qualified Data.Set as Set
-- >>> let po = fromLeq Set.isSubsetOf :: PartialOrder (Set.Set Int)
-- >>> runPartialOrder po (Set.fromList [1]) (Set.fromList [1,2])
-- Just LT
-- >>> runPartialOrder po (Set.fromList [1,2]) (Set.fromList [1,2])
-- Just EQ
-- >>> runPartialOrder po (Set.fromList [1,2]) (Set.fromList [1])
-- Just GT
-- >>> runPartialOrder po (Set.fromList [1,2]) (Set.fromList [2,3])
-- Nothing
fromLeq :: (a -> a -> Bool) -> PartialOrder a
fromLeq leq = PartialOrder $ \a b ->
  case (leq a b, leq b a) of
    (True, True) -> Just EQ
    (True, False) -> Just LT
    (False, True) -> Just GT
    (False, False) -> Nothing

-- |
-- >>> import Data.Functor.Contravariant (contramap)
-- >>> runPartialOrder (contramap negate (totalOrder :: PartialOrder Int)) 1 2
-- Just GT
-- >>> runPartialOrder (contramap negate (totalOrder :: PartialOrder Int)) 2 1
-- Just LT
instance Contravariant PartialOrder where
  contramap f (PartialOrder g) = PartialOrder (\a b -> g (f a) (f b))

-- | Lexicographic composition as a first-class 'Semigroup': compare by the
-- first partial order; if equal ('Just' 'EQ'), compare by the second.
-- If the first yields 'Nothing' (incomparable), the result is 'Nothing'.
--
-- >>> let po = totalOrder :: PartialOrder Int
-- >>> runPartialOrder (runSemigroup semigroupPartialOrder po po) 1 2
-- Just LT
-- >>> runPartialOrder (runSemigroup semigroupPartialOrder po po) 2 2
-- Just EQ
semigroupPartialOrder :: Semigroup (PartialOrder a)
semigroupPartialOrder = review applySemigroup $ \(PartialOrder f) (PartialOrder g) -> PartialOrder $ \a b ->
  case f a b of
    Just EQ -> g a b
    r -> r

-- |
-- >>> let po = totalOrder :: PartialOrder Int
-- >>> runPartialOrder (po <> po) 1 2
-- Just LT
-- >>> runPartialOrder (po <> po) 2 2
-- Just EQ
instance Prelude.Semigroup (PartialOrder a) where
  (<>) = runSemigroup semigroupPartialOrder

-- | The trivial partial order where all elements are equal.
--
-- >>> runPartialOrder (mempty :: PartialOrder Int) 1 2
-- Just EQ
-- >>> runPartialOrder (mempty :: PartialOrder Int) 42 99
-- Just EQ
instance Monoid (PartialOrder a) where
  mempty = PartialOrder (\_ _ -> Just EQ)

-- | Lexicographic product: split @a@ into @(b, c)@, compare by @b@ first,
-- if equal then compare by @c@. @conquer@ treats all elements as equal.
--
-- >>> import Data.Functor.Contravariant.Divisible (divide, conquer)
-- >>> let po = divide id (totalOrder :: PartialOrder Int) (totalOrder :: PartialOrder Int)
-- >>> runPartialOrder po (1, 2) (1, 3)
-- Just LT
-- >>> runPartialOrder po (1, 2) (2, 1)
-- Just LT
-- >>> runPartialOrder po (1, 2) (1, 2)
-- Just EQ
--
-- >>> import Data.Functor.Contravariant.Divisible (conquer)
-- >>> runPartialOrder (conquer :: PartialOrder Int) 1 2
-- Just EQ
instance Divisible PartialOrder where
  conquer = mempty
  divide f pb pc = contramap (fst . f) pb <> contramap (snd . f) pc

-- | Disjoint sum: classify @a@ as 'Left' @b@ or 'Right' @c@.
-- Elements on the same side are compared by that side's order.
-- Elements on different sides are incomparable ('Nothing').
--
-- >>> import Data.Functor.Contravariant.Divisible (choose, lose)
-- >>> import Data.Void (Void, absurd)
-- >>> let po = choose id (totalOrder :: PartialOrder Int) (totalOrder :: PartialOrder String)
-- >>> runPartialOrder po (Left 1) (Left 2)
-- Just LT
-- >>> runPartialOrder po (Right "a") (Right "b")
-- Just LT
-- >>> runPartialOrder po (Left 1) (Right "a")
-- Nothing
-- >>> runPartialOrder po (Right "a") (Left 1)
-- Nothing
--
-- >>> import Data.Functor.Contravariant.Divisible (lose)
-- >>> import Data.Void (Void, absurd)
-- >>> let po = lose absurd :: PartialOrder Void
-- >>> seq po ()
-- ()
instance Decidable PartialOrder where
  lose f = PartialOrder (\a _ -> absurd (f a))
  choose f pb pc = PartialOrder $ \a1 a2 ->
    case (f a1, f a2) of
      (Left b1, Left b2) -> runPartialOrder pb b1 b2
      (Right c1, Right c2) -> runPartialOrder pc c1 c2
      _ -> Nothing

-- |
-- >>> import Data.Functor.Contravariant.Divise (divise)
-- >>> let po = divise id (totalOrder :: PartialOrder Int) (totalOrder :: PartialOrder Int)
-- >>> runPartialOrder po (1, 2) (1, 3)
-- Just LT
-- >>> runPartialOrder po (1, 2) (1, 2)
-- Just EQ
instance Divise PartialOrder where
  divise = divide

-- |
-- >>> import Data.Functor.Contravariant.Decide (decide)
-- >>> let po = decide id (totalOrder :: PartialOrder Int) (totalOrder :: PartialOrder String)
-- >>> runPartialOrder po (Left 1) (Left 2)
-- Just LT
-- >>> runPartialOrder po (Left 1) (Right "a")
-- Nothing
instance Decide PartialOrder where
  decide = choose

-- |
-- >>> import Data.Functor.Contravariant.Conclude (conclude)
-- >>> import Data.Void (absurd)
-- >>> let po = conclude absurd :: PartialOrder Void
-- >>> seq po ()
-- ()
instance Conclude PartialOrder where
  conclude = lose