PartialOrder.hs

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

-- | A partial order on a type, generalised over a 'Profunctor' @p@,
-- wrapping @p a (p a ('Maybe' 'Ordering'))@.
-- When @p ~ (->)@, this specialises to @a -> a -> 'Maybe' 'Ordering'@
-- (see 'PartialOrder'').
--
-- 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 (..),
    PartialOrder',

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

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

import Control.Lens
  ( Lens',
    Prism',
    Rewrapped,
    Wrapped (..),
    iso,
    review,
  )
import Data.Functor.Apply (Apply, liftF2)
import Data.Functor.Contravariant
  ( Comparison (Comparison),
    Contravariant (contramap),
    Equivalence (Equivalence),
  )
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.Profunctor (Profunctor (..))
import qualified Data.Profunctor.Rep as Pro
import Data.Profunctor.Sieve (Sieve (..))
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 p a
  = PartialOrder (p a (p a (Maybe Ordering)))

type PartialOrder' a =
  PartialOrder (->) a

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 p a | c -> p a where
  partialOrder :: Lens' c (PartialOrder p a)

instance HasPartialOrder (PartialOrder p a) p a where
  partialOrder = id

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

instance AsPartialOrder (PartialOrder p a) p a where
  _PartialOrder = id

-- | Unwrap the partial order to its underlying profunctor value.
-- For @p ~ (->)@, this gives @a -> a -> 'Maybe' 'Ordering'@.
--
-- >>> 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 p a -> p a (p 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))

-- | Lift a 'Comparison' (a reified total order) into a 'PartialOrder''.
-- Since a total order has no incomparable elements, the result
-- always yields @'Just' o@ for some 'Ordering' @o@, never 'Nothing'.
--
-- >>> import Data.Functor.Contravariant (Comparison(..))
-- >>> runPartialOrder (comparisonTotalOrder (Comparison compare)) (1 :: Int) 2
-- Just LT
-- >>> runPartialOrder (comparisonTotalOrder (Comparison compare)) (2 :: Int) 2
-- Just EQ
-- >>> runPartialOrder (comparisonTotalOrder (Comparison compare)) (3 :: Int) 2
-- Just GT
--
-- >>> import Data.Functor.Contravariant (Comparison(..), contramap)
-- >>> runPartialOrder (comparisonTotalOrder (contramap negate (Comparison compare))) (1 :: Int) 2
-- Just GT
--
-- >>> import Data.Functor.Contravariant (Comparison(..))
-- >>> partialOrderLeq (comparisonTotalOrder (Comparison compare)) (1 :: Int) 2
-- True
-- >>> partialOrderLeq (comparisonTotalOrder (Comparison compare)) (2 :: Int) 1
-- False
comparisonTotalOrder :: Comparison a -> PartialOrder' a
comparisonTotalOrder (Comparison cmp) = PartialOrder (\a1 a2 -> Just (cmp a1 a2))

fromEquivalence :: (Bool -> Maybe Ordering) -> Equivalence a -> PartialOrder' a
fromEquivalence k (Equivalence p) = PartialOrder (\a1 a2 -> k (p a1 a2))

-- | 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 (Profunctor p) => Contravariant (PartialOrder p) where
  contramap f (PartialOrder g) = PartialOrder (dimap f (lmap f) g)

-- | 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 :: (Pro.Representable p, Apply (Pro.Rep p)) => Semigroup' (PartialOrder p a)
semigroupPartialOrder = review applySemigroup $ \(PartialOrder pf) (PartialOrder pg) ->
  PartialOrder $ Pro.tabulate $ \a ->
    liftF2
      ( \innerF innerG -> Pro.tabulate $ \b ->
          liftF2 (\r1 r2 -> case r1 of Just EQ -> r2; _ -> r1) (sieve innerF b) (sieve innerG b)
      )
      (sieve pf a)
      (sieve pg a)
{-# SPECIALIZE semigroupPartialOrder :: Semigroup' (PartialOrder' a) #-}

-- |
-- >>> let po = totalOrder :: PartialOrder' Int
-- >>> runPartialOrder (po <> po) 1 2
-- Just LT
-- >>> runPartialOrder (po <> po) 2 2
-- Just EQ
instance (Pro.Representable p, Apply (Pro.Rep p)) => Prelude.Semigroup (PartialOrder p 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 (Pro.Representable p, Apply (Pro.Rep p), Applicative (Pro.Rep p)) => Monoid (PartialOrder p a) where
  mempty = PartialOrder (Pro.tabulate (\_ -> pure (Pro.tabulate (\_ -> pure (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 (Pro.Representable p, Apply (Pro.Rep p), Applicative (Pro.Rep p)) => Divisible (PartialOrder p) 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 (Pro.Representable p, Apply (Pro.Rep p), Monad (Pro.Rep p)) => Decidable (PartialOrder p) where
  lose f = PartialOrder (Pro.tabulate (absurd . f))
  choose f pb pc = PartialOrder $ Pro.tabulate $ \a1 ->
    pure $ Pro.tabulate $ \a2 ->
      case (f a1, f a2) of
        (Left b1, Left b2) -> sieve (runPartialOrder pb) b1 >>= \inner -> sieve inner b2
        (Right c1, Right c2) -> sieve (runPartialOrder pc) c1 >>= \inner -> sieve inner c2
        _ -> pure 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 (Pro.Representable p, Apply (Pro.Rep p)) => Divise (PartialOrder p) where
  divise f pb pc = contramap (fst . f) pb <> contramap (snd . f) pc

-- |
-- >>> 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 (Pro.Representable p, Apply (Pro.Rep p), Monad (Pro.Rep p)) => Decide (PartialOrder p) where
  decide = choose

-- |
-- >>> import Data.Functor.Contravariant.Conclude (conclude)
-- >>> import Data.Void (absurd)
-- >>> let po = conclude absurd :: PartialOrder' Void
-- >>> seq po ()
-- ()
instance (Pro.Representable p, Apply (Pro.Rep p), Monad (Pro.Rep p)) => Conclude (PartialOrder p) where
  conclude = lose