module Data.Difference (Difference (..), negate) where

import qualified "base" Prelude as Base
import qualified "base" Data.Monoid as Base

data Difference a = Neg a | Zero | Pos a
  deriving (Foldable, Functor, Traversable, Base.Eq, Show)

instance PartialEq a => PartialEq (Difference a) where
    (≡) = Base.getAny ∘∘ getConst ∘∘ liftCompare' (Const ∘∘ Base.Any ∘∘ (≡))
instance Preord a => Preord (Difference a) where
    Neg a ≤ Neg b = b ≤ a
    Neg _ ≤ _     = True
    _     ≤ Neg _ = False
    Pos a ≤ Pos b = a ≤ b
    Pos _ ≤ _     = False
    _     ≤ Pos _ = True
    Zero   ≤ Zero   = True
instance PartialOrd a => PartialOrd (Difference a) where
    tryCompare = liftCompare' tryCompare
instance Eq a => Eq (Difference a)
instance Ord a => Ord (Difference a) where
    compare = runIdentity ∘∘ liftCompare' (Identity ∘∘ compare)

instance Base.Ord a => Base.Ord (Difference a) where
    compare = runIdentity ∘∘ liftCompare' (Identity ∘∘ Base.compare)

liftCompare' :: Applicative f => (a -> b -> f Ordering) -> Difference a -> Difference b -> f Ordering
liftCompare' cmp = curry $ \ case
    (Neg a, Neg b) -> op <$> cmp a b
    (Neg _, _)     -> pure LT
    (_,     Neg _) -> pure GT
    (Pos a, Pos b) -> cmp a b
    (Pos _, _)     -> pure GT
    (_,     Pos _) -> pure LT
    (Zero,   Zero)   -> pure EQ
  where
    op = \ case LT -> GT; GT -> LT; EQ -> EQ

instance Applicative Difference where
    pure = Pos
    Zero <*> _ = Zero
    Neg f <*> x = negate (f <$> x)
    Pos f <*> x = id     (f <$> x)

negate :: Difference a -> Difference a
negate = \ case
    Zero -> Zero
    Neg a -> Pos a
    Pos a -> Neg a