{-# language AllowAmbiguousTypes #-}
{-# language DataKinds #-}
{-# language DefaultSignatures #-}
{-# language DisambiguateRecordFields #-}
{-# language FlexibleContexts #-}
{-# language FlexibleInstances #-}
{-# language ScopedTypeVariables #-}
{-# language StandaloneKindSignatures #-}
{-# language TypeApplications #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language UndecidableInstances #-}
{-# language ViewPatterns #-}

module Rel8.Table.Ord
  ( OrdTable( ordTable ), (<:), (<=:), (>:), (>=:), least, greatest
  )
where

-- base
import Data.Functor.Const ( Const( Const ), getConst )
import Data.Kind ( Constraint, Type )
import GHC.Generics ( Rep )
import Prelude hiding ( seq )

-- rel8
import Rel8.Expr ( Expr )
import Rel8.Expr.Bool ( (||.), (&&.), false, true )
import Rel8.Expr.Eq ( (==.) )
import Rel8.Expr.Ord ( (<.), (>.) )
import Rel8.FCF ( Eval, Exp )
import Rel8.Generic.Record ( Record )
import Rel8.Generic.Table.Record ( GTable, GColumns, gtable )
import Rel8.Schema.Dict ( Dict( Dict ) )
import Rel8.Schema.HTable ( htabulateA, hfield )
import Rel8.Schema.HTable.Identity ( HIdentity( HIdentity ) )
import Rel8.Schema.Null (Sql)
import Rel8.Table ( Columns, toColumns, TColumns )
import Rel8.Table.Bool ( bool )
import Rel8.Table.Eq ( EqTable )
import Rel8.Type.Ord ( DBOrd )


-- | The class of 'Table's that can be ordered. Ordering on tables is defined
-- by their lexicographic ordering of all columns, so this class means "all
-- columns in a 'Table' have an instance of 'DBOrd'".
type OrdTable :: Type -> Constraint
class EqTable a => OrdTable a where
  ordTable :: Columns a (Dict (Sql DBOrd))

  default ordTable ::
    ( GTable TOrdTable TColumns (Rep (Record a))
    , Columns a ~ GColumns TColumns (Rep (Record a))
    )
    => Columns a (Dict (Sql DBOrd))
  ordTable = forall (_Table :: * -> Exp Constraint)
       (_Columns :: * -> Exp HTable) (rep :: Context)
       (context :: Context).
GTable _Table _Columns rep =>
(forall a (proxy :: Context).
 Eval (_Table a) =>
 proxy a -> Eval (_Columns a) context)
-> GColumns _Columns rep context
gtable @TOrdTable @TColumns @(Rep (Record a)) proxy a -> Eval (TColumns a) (Dict (Sql DBOrd))
proxy a -> Columns a (Dict (Sql DBOrd))
forall {x} {proxy :: Context}.
(Context x ~ Expr, Transpose Expr x ~ x, OrdTable x) =>
proxy x -> Columns x (Dict (Sql DBOrd))
forall a (proxy :: Context).
Eval (TOrdTable a) =>
proxy a -> Eval (TColumns a) (Dict (Sql DBOrd))
table
    where
      table :: proxy x -> Columns x (Dict (Sql DBOrd))
table (proxy x
_ :: proxy x) = forall a. OrdTable a => Columns a (Dict (Sql DBOrd))
ordTable @x


data TOrdTable :: Type -> Exp Constraint
type instance Eval (TOrdTable a) = OrdTable a


instance Sql DBOrd a => OrdTable (Expr a) where
  ordTable :: Columns (Expr a) (Dict (Sql DBOrd))
ordTable = Dict (Sql DBOrd) a -> HIdentity a (Dict (Sql DBOrd))
forall a (context :: Context). context a -> HIdentity a context
HIdentity Dict (Sql DBOrd) a
forall {a} (c :: a -> Constraint) (a1 :: a). c a1 => Dict c a1
Dict


instance (OrdTable a, OrdTable b) => OrdTable (a, b)


instance (OrdTable a, OrdTable b, OrdTable c) => OrdTable (a, b, c)


instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d) => OrdTable (a, b, c, d)


instance (OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e) =>
  OrdTable (a, b, c, d, e)


instance
  ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
  )
  => OrdTable (a, b, c, d, e, f)


instance
  ( OrdTable a, OrdTable b, OrdTable c, OrdTable d, OrdTable e, OrdTable f
  , OrdTable g
  )
  => OrdTable (a, b, c, d, e, f, g)


-- | Test if one 'Table' sorts before another. Corresponds to comparing all
-- columns with '<'.
(<:) :: forall a. OrdTable a => a -> a -> Expr Bool
(a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
as) <: :: forall a. OrdTable a => a -> a -> Expr Bool
<: (a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
bs) =
  forall (t :: Context) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr @[] (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go Expr Bool
false ([(Expr Bool, Expr Bool)] -> Expr Bool)
-> [(Expr Bool, Expr Bool)] -> Expr Bool
forall a b. (a -> b) -> a -> b
$ Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall {k} a (b :: k). Const a b -> a
getConst (Const [(Expr Bool, Expr Bool)] (Columns a Any)
 -> [(Expr Bool, Expr Bool)])
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall a b. (a -> b) -> a -> b
$ (forall a.
 HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a.
  HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
 -> Const [(Expr Bool, Expr Bool)] (Columns a Any))
-> (forall a.
    HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field ->
    case (Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
as HField (Columns a) a
field, Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
bs HField (Columns a) a
field) of
      (Expr a
a, Expr a
b) -> case Columns a (Dict (Sql DBOrd))
-> HField (Columns a) a -> Dict (Sql DBOrd) a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall a. OrdTable a => Columns a (Dict (Sql DBOrd))
ordTable @a) HField (Columns a) a
field of
        Dict (Sql DBOrd) a
Dict -> [(Expr Bool, Expr Bool)] -> Const [(Expr Bool, Expr Bool)] (Any a)
forall {k} a (b :: k). a -> Const a b
Const [(Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
<. Expr a
b, Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Expr a
b)]
  where
    go :: (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go (Expr Bool
lt, Expr Bool
eq) Expr Bool
a = Expr Bool
lt Expr Bool -> Expr Bool -> Expr Bool
||. (Expr Bool
eq Expr Bool -> Expr Bool -> Expr Bool
&&. Expr Bool
a)
infix 4 <:


-- | Test if one 'Table' sorts before, or is equal to, another. Corresponds to
-- comparing all columns with '<='.
(<=:) :: forall a. OrdTable a => a -> a -> Expr Bool
(a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
as) <=: :: forall a. OrdTable a => a -> a -> Expr Bool
<=: (a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
bs) =
  forall (t :: Context) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr @[] (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go Expr Bool
true ([(Expr Bool, Expr Bool)] -> Expr Bool)
-> [(Expr Bool, Expr Bool)] -> Expr Bool
forall a b. (a -> b) -> a -> b
$ Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall {k} a (b :: k). Const a b -> a
getConst (Const [(Expr Bool, Expr Bool)] (Columns a Any)
 -> [(Expr Bool, Expr Bool)])
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall a b. (a -> b) -> a -> b
$ (forall a.
 HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a.
  HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
 -> Const [(Expr Bool, Expr Bool)] (Columns a Any))
-> (forall a.
    HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field ->
    case (Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
as HField (Columns a) a
field, Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
bs HField (Columns a) a
field) of
      (Expr a
a, Expr a
b) -> case Columns a (Dict (Sql DBOrd))
-> HField (Columns a) a -> Dict (Sql DBOrd) a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall a. OrdTable a => Columns a (Dict (Sql DBOrd))
ordTable @a) HField (Columns a) a
field of
        Dict (Sql DBOrd) a
Dict -> [(Expr Bool, Expr Bool)] -> Const [(Expr Bool, Expr Bool)] (Any a)
forall {k} a (b :: k). a -> Const a b
Const [(Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
<. Expr a
b, Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Expr a
b)]
  where
    go :: (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go (Expr Bool
lt, Expr Bool
eq) Expr Bool
a = Expr Bool
lt Expr Bool -> Expr Bool -> Expr Bool
||. (Expr Bool
eq Expr Bool -> Expr Bool -> Expr Bool
&&. Expr Bool
a)
infix 4 <=:


-- | Test if one 'Table' sorts after another. Corresponds to comparing all
-- columns with '>'.
(>:) :: forall a. OrdTable a => a -> a -> Expr Bool
(a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
as) >: :: forall a. OrdTable a => a -> a -> Expr Bool
>: (a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
bs) =
  forall (t :: Context) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr @[] (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go Expr Bool
false ([(Expr Bool, Expr Bool)] -> Expr Bool)
-> [(Expr Bool, Expr Bool)] -> Expr Bool
forall a b. (a -> b) -> a -> b
$ Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall {k} a (b :: k). Const a b -> a
getConst (Const [(Expr Bool, Expr Bool)] (Columns a Any)
 -> [(Expr Bool, Expr Bool)])
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall a b. (a -> b) -> a -> b
$ (forall a.
 HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a.
  HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
 -> Const [(Expr Bool, Expr Bool)] (Columns a Any))
-> (forall a.
    HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field ->
    case (Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
as HField (Columns a) a
field, Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
bs HField (Columns a) a
field) of
      (Expr a
a, Expr a
b) -> case Columns a (Dict (Sql DBOrd))
-> HField (Columns a) a -> Dict (Sql DBOrd) a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall a. OrdTable a => Columns a (Dict (Sql DBOrd))
ordTable @a) HField (Columns a) a
field of
        Dict (Sql DBOrd) a
Dict -> [(Expr Bool, Expr Bool)] -> Const [(Expr Bool, Expr Bool)] (Any a)
forall {k} a (b :: k). a -> Const a b
Const [(Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
>. Expr a
b, Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Expr a
b)]
  where
    go :: (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go (Expr Bool
gt, Expr Bool
eq) Expr Bool
a = Expr Bool
gt Expr Bool -> Expr Bool -> Expr Bool
||. (Expr Bool
eq Expr Bool -> Expr Bool -> Expr Bool
&&. Expr Bool
a)
infix 4 >:


-- | Test if one 'Table' sorts after another. Corresponds to comparing all
-- columns with '>='.
(>=:) :: forall a. OrdTable a => a -> a -> Expr Bool
(a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
as) >=: :: forall a. OrdTable a => a -> a -> Expr Bool
>=: (a -> Columns a Expr
forall (context :: Context) a.
Table context a =>
a -> Columns a context
toColumns -> Columns a Expr
bs) =
  forall (t :: Context) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr @[] (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go Expr Bool
true ([(Expr Bool, Expr Bool)] -> Expr Bool)
-> [(Expr Bool, Expr Bool)] -> Expr Bool
forall a b. (a -> b) -> a -> b
$ Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall {k} a (b :: k). Const a b -> a
getConst (Const [(Expr Bool, Expr Bool)] (Columns a Any)
 -> [(Expr Bool, Expr Bool)])
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
-> [(Expr Bool, Expr Bool)]
forall a b. (a -> b) -> a -> b
$ (forall a.
 HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall (t :: HTable) (m :: Context) (context :: Context).
(HTable t, Apply m) =>
(forall a. HField t a -> m (context a)) -> m (t context)
htabulateA ((forall a.
  HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
 -> Const [(Expr Bool, Expr Bool)] (Columns a Any))
-> (forall a.
    HField (Columns a) a -> Const [(Expr Bool, Expr Bool)] (Any a))
-> Const [(Expr Bool, Expr Bool)] (Columns a Any)
forall a b. (a -> b) -> a -> b
$ \HField (Columns a) a
field ->
    case (Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
as HField (Columns a) a
field, Columns a Expr -> HField (Columns a) a -> Expr a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield Columns a Expr
bs HField (Columns a) a
field) of
      (Expr a
a, Expr a
b) -> case Columns a (Dict (Sql DBOrd))
-> HField (Columns a) a -> Dict (Sql DBOrd) a
forall (context :: Context) a.
Columns a context -> HField (Columns a) a -> context a
forall (t :: HTable) (context :: Context) a.
HTable t =>
t context -> HField t a -> context a
hfield (forall a. OrdTable a => Columns a (Dict (Sql DBOrd))
ordTable @a) HField (Columns a) a
field of
        Dict (Sql DBOrd) a
Dict -> [(Expr Bool, Expr Bool)] -> Const [(Expr Bool, Expr Bool)] (Any a)
forall {k} a (b :: k). a -> Const a b
Const [(Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBOrd a => Expr a -> Expr a -> Expr Bool
>. Expr a
b, Expr a
a Expr a -> Expr a -> Expr Bool
forall a. Sql DBEq a => Expr a -> Expr a -> Expr Bool
==. Expr a
b)]
  where
    go :: (Expr Bool, Expr Bool) -> Expr Bool -> Expr Bool
go (Expr Bool
gt, Expr Bool
eq) Expr Bool
a = Expr Bool
gt Expr Bool -> Expr Bool -> Expr Bool
||. (Expr Bool
eq Expr Bool -> Expr Bool -> Expr Bool
&&. Expr Bool
a)
infix 4 >=:


-- | Given two 'Table's, return the table that sorts before the other.
least :: OrdTable a => a -> a -> a
least :: forall a. OrdTable a => a -> a -> a
least a
a a
b = a -> a -> Expr Bool -> a
forall a. Table Expr a => a -> a -> Expr Bool -> a
bool a
b a
a (a
a a -> a -> Expr Bool
forall a. OrdTable a => a -> a -> Expr Bool
<: a
b)


-- | Given two 'Table's, return the table that sorts after the other.
greatest :: OrdTable a => a -> a -> a
greatest :: forall a. OrdTable a => a -> a -> a
greatest a
a a
b = a -> a -> Expr Bool -> a
forall a. Table Expr a => a -> a -> Expr Bool -> a
bool a
b a
a (a
a a -> a -> Expr Bool
forall a. OrdTable a => a -> a -> Expr Bool
>: a
b)