{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}

module Data.Ord.Ordering where

import Control.Category (Category(..) )
import Control.Lens
    ( view,
      isn't,
      (#),
      iso,
      prism',
      Getting,
      Prism',
      _Just,
      Iso )
import Control.Monad.State
    ( StateT, evalStateT )
import Data.Bool(bool)
import Data.Functor.Identity ( Identity(..) )
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Functor.Contravariant.Divisible
    ( Decidable(..), Divisible(..) )
import Data.Void ( absurd )
import Prelude hiding (id, (.) )

type OrderingKnownEq =
  Maybe Ordering

newtype Order b a =
  Order (a -> a -> b)

class IsOrdering a where
  _Ordering ::
    Prism' a Ordering
  _LT ::
    Prism' a ()
  _LT =
    _Ordering .
    prism'
      (\() -> LT)
      (\case  LT ->
                Just ()
              _ ->
                Nothing
      )
  _EQ ::
    Prism' a ()
  _EQ =
    _Ordering .
    prism'
      (\() -> EQ)
      (\case  EQ ->
                Just ()
              _ ->
                Nothing
      )
  _GT ::
    Prism' a ()
  _GT =
    _Ordering .
    prism'
      (\() -> GT)
      (\case  GT ->
                Just ()
              _ ->
                Nothing
      )

instance IsOrdering Ordering where
  _Ordering =
    id

instance IsOrdering (Maybe Bool) where
  _Ordering =
    iso
      (\case  Nothing ->
                LT
              Just False ->
                EQ
              Just True ->
                GT
      )
      (\case  LT ->
                Nothing
              EQ ->
                Just False
              GT ->
                Just True
      )

class IsOrdering a => IsOrderingKnownEq a where
  _OrderingKnownEq ::
    Prism' a OrderingKnownEq
  _KnownEQ ::
    Prism' a ()
  _KnownEQ =
    _OrderingKnownEq .
    prism'
      (\() -> Nothing)
      (\case  Nothing ->
                Just ()
              _ ->
                Nothing
      )

instance IsOrdering OrderingKnownEq where
  _Ordering =
    _Just . _Ordering

instance IsOrderingKnownEq OrderingKnownEq where
  _OrderingKnownEq =
    id

order ::
  Iso
    (Order b a)
    (Order b' a')
    (a -> a -> b)
    (a' -> a' -> b')
order =
  iso
    (\(Order x) -> x)
    Order

instance Semigroup b => Semigroup (Order b a) where
  Order f <> Order g =
    Order (\a1 a2 -> f a1 a2 <> g a1 a2)

instance Monoid b => Monoid (Order b a) where
  mempty =
    Order (\_ _ -> mempty)

instance Contravariant (Order b) where
  contramap f (Order g) =
    Order (\a1 a2 -> g (f a1) (f a2))

instance Monoid b => Divisible (Order b) where
  divide f (Order g) (Order h) =
    Order (\a1 a2 -> let (b1, c1) = f a1
                         (b2, c2) = f a2
                     in  g b1 b2 <> h c1 c2)
  conquer =
    Order (\_ _ -> mempty)

instance Monoid b =>  Decidable (Order b) where
  choose f (Order g) (Order h) =
    Order (\a1 a2 -> let e1 = f a1
                         e2 = f a2
                     in  either (either g (\_ _ -> mempty) e2) (either (\_ _ -> mempty) h e2) e1)
  lose f =
    Order (\a1 a2 -> absurd (f a1 <> f a2))

lt ::
  IsOrdering b =>
  Order b a
lt =
  Order (\_ _ -> _LT # ())

isLT ::
  IsOrdering b =>
  Order b a
  -> a
  -> a
  -> Bool
isLT (Order f) a1 a2 =
  not (isn't _LT (f a1 a2))

ifLT ::
  IsOrdering x =>
  a
  -> a
  -> x
  -> a
ifLT a1 a2 =
  bool a2 a1 . not . isn't _LT

eq ::
  IsOrdering b =>
  Order b a
eq =
  Order (\_ _ -> _EQ # ())

isEQ ::
  IsOrdering b =>
  Order b a
  -> a
  -> a
  -> Bool
isEQ (Order f) a1 a2 =
  not (isn't _EQ (f a1 a2))

ifEQ ::
  IsOrdering x =>
  a
  -> a
  -> x
  -> a
ifEQ a1 a2 =
  bool a2 a1 . not . isn't _EQ

gt ::
  IsOrdering b =>
  Order b a
gt =
  Order (\_ _ -> _GT # ())

isGT ::
  IsOrdering b =>
  Order b a
  -> a
  -> a
  -> Bool
isGT (Order f) a1 a2 =
  not (isn't _GT (f a1 a2))

ifGT ::
  IsOrdering x =>
  a
  -> a
  -> x
  -> a
ifGT a1 a2 =
  bool a2 a1 . not . isn't _GT

knownEq ::
  IsOrderingKnownEq b =>
  Order b a
knownEq =
  Order (\_ _ -> _KnownEQ # ())

isKnownEq ::
  IsOrderingKnownEq b =>
  Order b a
  -> a
  -> a
  -> Bool
isKnownEq (Order f) a1 a2 =
  not (isn't _KnownEQ (f a1 a2))

ifKnownEq ::
  IsOrderingKnownEq x =>
  a
  -> a
  -> x
  -> a
ifKnownEq a1 a2 =
  bool a2 a1 . not . isn't _KnownEQ

ordOrder ::
  (Ord a, IsOrdering b) =>
  Order b a
ordOrder =
  Order (\a1 a2 -> case compare a1 a2 of
                      LT ->
                        _LT # ()
                      GT ->
                        _GT # ()
                      EQ ->
                        _EQ # ())

knownUnknownOrdering ::
  (IsOrderingKnownEq t, IsOrderingKnownEq a) =>
  t
  -> a
knownUnknownOrdering x =
  ifEQ
    (_KnownEQ # ())
    (
      ifKnownEq
        (_EQ # ())
        (
          ifLT
            (_LT # ())
            (_GT # ())
            x
        )
        x
    )
    x

mapOrdering ::
  (b -> b')
  -> Order b a
  -> Order b' a
mapOrdering f (Order g) =
  Order (\a1 a2 -> f (g a1 a2))

knownUnknownOrder ::
  IsOrderingKnownEq b =>
  Order b a
  -> Order b a
knownUnknownOrder =
  mapOrdering knownUnknownOrdering

(*>>) ::
  Applicative f =>
  Order (f a1) a2
  -> Order (f b) a2
  -> Order (f b) a2
(*>>) (Order f) (Order g) =
  Order (\a1 a2 -> f a1 a2 *> g a1 a2)

infixr 6 *>>

appendOrder ::
  Semigroup x =>
  Order x x
appendOrder =
  Order (<>)

listOrder ::
  (IsOrdering b, Semigroup b) =>
  Order b a
  -> Order b [a]
listOrder (Order f) =
  let lists [] [] =
        _EQ # ()
      lists [] (_:_) =
        _LT # ()
      lists (_:_) [] =
        _GT # ()
      lists (h1:t1) (h2:t2) =
        f h1 h2 <> lists t1 t2
  in  Order lists

orderL ::
  Contravariant f =>
  Getting a s a
  -> f a
  -> f s
orderL =
  contramap . view

orderL' ::
  (Ord a, IsOrdering b) =>
  Getting a s a
  -> Order b s
orderL' x =
  orderL x ordOrder

orderS ::
  Contravariant f =>
  StateT a Identity b
  -> f b
  -> f a
orderS x =
  contramap (runIdentity . evalStateT x)

orderS' ::
  (Ord x, IsOrdering b) =>
  StateT a Identity x
  -> Order b a
orderS' x =
  orderS x ordOrder

duplicates ::
  KnownEqOrd OrderingKnownEq a =>
  (t -> a)
  -> [t]
  -> [(t, t)]
duplicates ord t =
  let isEQ' :: Order OrderingKnownEq a -> a -> a -> Bool
      isEQ' = isEQ
      pairs ::
        [a]
        -> [(a, a)]
      pairs [] =
        []
      pairs (h:r) =
        fmap (h,) r <> pairs r
  in  filter (\(t1, t2) -> isEQ' knownEqCompare (ord t1) (ord t2)) (pairs t)

class Ord a => KnownEqOrd b a where
  knownEqCompare ::
    Order b a

areEqual ::
  (Eq a, IsOrdering b) =>
  a
  -> a
  -> Order b a
  -> Order b a
areEqual a1' a2' (Order f) =
  Order (\a1 a2 -> bool (f a1' a2') (_EQ # ()) ((a1 == a1' && a2 == a2') || (a1 == a2' && a2 == a1')))

(.===.) ::
  (Ord a, IsOrdering b) =>
  a
  -> a
  -> Order b a
a1 .===. a2 =
  areEqual a1 a2 ordOrder