module Opaleye.Internal.Order where

import           Data.Function                        (on)
import qualified Data.Functor.Contravariant           as C
import qualified Data.Functor.Contravariant.Divisible as Divisible
import qualified Data.List.NonEmpty                   as NL
import qualified Data.Monoid                          as M
import qualified Data.Profunctor                      as P
import qualified Data.Semigroup                       as S
import qualified Data.Void                            as Void
import qualified Opaleye.Column                       as C
import qualified Opaleye.Internal.Column              as IC
import qualified Opaleye.Internal.HaskellDB.PrimQuery as HPQ
import qualified Opaleye.Internal.PrimQuery           as PQ
import qualified Opaleye.Internal.Tag                 as T
import qualified Opaleye.Internal.Unpackspec          as U

{-|
An `Order` @a@ represents a sort order and direction for the elements
of the type @a@. Multiple `Order`s can be composed with
`Data.Monoid.mappend` or @(\<\>)@ from "Data.Monoid".  If two rows are
equal according to the first `Order` in the @mappend@, the second is
used, and so on.
-}

-- Like the (columns -> RowParser haskells) field of FromFields this
-- type is "too big".  We never actually look at the 'a' (in the
-- FromFields case the 'columns') except to check the "structure".
-- This is so we can support a SumProfunctor instance.
newtype Order a = Order (a -> [(HPQ.OrderOp, HPQ.PrimExpr)])

instance C.Contravariant Order where
  contramap :: (a -> b) -> Order b -> Order a
contramap a -> b
f (Order b -> [(OrderOp, PrimExpr)]
g) = (a -> [(OrderOp, PrimExpr)]) -> Order a
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order ((a -> b)
-> (b -> [(OrderOp, PrimExpr)]) -> a -> [(OrderOp, PrimExpr)]
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
P.lmap a -> b
f b -> [(OrderOp, PrimExpr)]
g)

instance S.Semigroup (Order a) where
  Order a -> [(OrderOp, PrimExpr)]
o <> :: Order a -> Order a -> Order a
<> Order a -> [(OrderOp, PrimExpr)]
o' = (a -> [(OrderOp, PrimExpr)]) -> Order a
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order (a -> [(OrderOp, PrimExpr)]
o (a -> [(OrderOp, PrimExpr)])
-> (a -> [(OrderOp, PrimExpr)]) -> a -> [(OrderOp, PrimExpr)]
forall a. Semigroup a => a -> a -> a
S.<> a -> [(OrderOp, PrimExpr)]
o')

instance M.Monoid (Order a) where
  mempty :: Order a
mempty = (a -> [(OrderOp, PrimExpr)]) -> Order a
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order a -> [(OrderOp, PrimExpr)]
forall a. Monoid a => a
M.mempty
  mappend :: Order a -> Order a -> Order a
mappend = Order a -> Order a -> Order a
forall a. Semigroup a => a -> a -> a
(S.<>)

instance Divisible.Divisible Order where
  divide :: (a -> (b, c)) -> Order b -> Order c -> Order a
divide a -> (b, c)
f Order b
o Order c
o' = Order a -> Order a -> Order a
forall a. Monoid a => a -> a -> a
M.mappend ((a -> b) -> Order b -> Order a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
C.contramap ((b, c) -> b
forall a b. (a, b) -> a
fst ((b, c) -> b) -> (a -> (b, c)) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (b, c)
f) Order b
o)
                            ((a -> c) -> Order c -> Order a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
C.contramap ((b, c) -> c
forall a b. (a, b) -> b
snd ((b, c) -> c) -> (a -> (b, c)) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (b, c)
f) Order c
o')
  conquer :: Order a
conquer = Order a
forall a. Monoid a => a
M.mempty

instance Divisible.Decidable Order where
  lose :: (a -> Void) -> Order a
lose a -> Void
f = (a -> Void) -> Order Void -> Order a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
C.contramap a -> Void
f ((Void -> [(OrderOp, PrimExpr)]) -> Order Void
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order Void -> [(OrderOp, PrimExpr)]
forall a. Void -> a
Void.absurd)
  choose :: (a -> Either b c) -> Order b -> Order c -> Order a
choose a -> Either b c
f (Order b -> [(OrderOp, PrimExpr)]
o) (Order c -> [(OrderOp, PrimExpr)]
o') = (a -> Either b c) -> Order (Either b c) -> Order a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
C.contramap a -> Either b c
f ((Either b c -> [(OrderOp, PrimExpr)]) -> Order (Either b c)
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order ((b -> [(OrderOp, PrimExpr)])
-> (c -> [(OrderOp, PrimExpr)])
-> Either b c
-> [(OrderOp, PrimExpr)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> [(OrderOp, PrimExpr)]
o c -> [(OrderOp, PrimExpr)]
o'))

order :: HPQ.OrderOp -> (a -> C.Column b) -> Order a
order :: OrderOp -> (a -> Column b) -> Order a
order OrderOp
op a -> Column b
f = (a -> [(OrderOp, PrimExpr)]) -> Order a
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order ((Column b -> [(OrderOp, PrimExpr)])
-> (a -> Column b) -> a -> [(OrderOp, PrimExpr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Column b
column -> [(OrderOp
op, Column b -> PrimExpr
forall a. Column a -> PrimExpr
IC.unColumn Column b
column)]) a -> Column b
f)

orderByU :: Order a -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)
orderByU :: Order a -> (a, PrimQuery, Tag) -> (a, PrimQuery, Tag)
orderByU Order a
os (a
columns, PrimQuery
primQ, Tag
t) = (a
columns, PrimQuery
primQ', Tag
t)
  where primQ' :: PrimQuery
primQ' = Maybe (NonEmpty PrimExpr) -> [OrderExpr] -> PrimQuery -> PrimQuery
forall a.
Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> PrimQuery' a -> PrimQuery' a
PQ.DistinctOnOrderBy Maybe (NonEmpty PrimExpr)
forall a. Maybe a
Nothing [OrderExpr]
oExprs PrimQuery
primQ
        oExprs :: [OrderExpr]
oExprs = a -> Order a -> [OrderExpr]
forall a. a -> Order a -> [OrderExpr]
orderExprs a
columns Order a
os

orderExprs :: a -> Order a -> [HPQ.OrderExpr]
orderExprs :: a -> Order a -> [OrderExpr]
orderExprs a
x (Order a -> [(OrderOp, PrimExpr)]
os) = ((OrderOp, PrimExpr) -> OrderExpr)
-> [(OrderOp, PrimExpr)] -> [OrderExpr]
forall a b. (a -> b) -> [a] -> [b]
map ((OrderOp -> PrimExpr -> OrderExpr)
-> (OrderOp, PrimExpr) -> OrderExpr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry OrderOp -> PrimExpr -> OrderExpr
HPQ.OrderExpr) (a -> [(OrderOp, PrimExpr)]
os a
x)

limit' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)
limit' :: Int -> (a, PrimQuery, Tag) -> (a, PrimQuery, Tag)
limit' Int
n (a
x, PrimQuery
q, Tag
t) = (a
x, LimitOp -> PrimQuery -> PrimQuery
forall a. LimitOp -> PrimQuery' a -> PrimQuery' a
PQ.Limit (Int -> LimitOp
PQ.LimitOp Int
n) PrimQuery
q, Tag
t)

offset' :: Int -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)
offset' :: Int -> (a, PrimQuery, Tag) -> (a, PrimQuery, Tag)
offset' Int
n (a
x, PrimQuery
q, Tag
t) = (a
x, LimitOp -> PrimQuery -> PrimQuery
forall a. LimitOp -> PrimQuery' a -> PrimQuery' a
PQ.Limit (Int -> LimitOp
PQ.OffsetOp Int
n) PrimQuery
q, Tag
t)

distinctOn :: U.Unpackspec b b -> (a -> b)
           -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)
distinctOn :: Unpackspec b b
-> (a -> b) -> (a, PrimQuery, Tag) -> (a, PrimQuery, Tag)
distinctOn Unpackspec b b
ups a -> b
proj = Unpackspec b b
-> (a -> b)
-> Order a
-> (a, PrimQuery, Tag)
-> (a, PrimQuery, Tag)
forall b a.
Unpackspec b b
-> (a -> b)
-> Order a
-> (a, PrimQuery, Tag)
-> (a, PrimQuery, Tag)
distinctOnBy Unpackspec b b
ups a -> b
proj Order a
forall a. Monoid a => a
M.mempty

distinctOnBy :: U.Unpackspec b b -> (a -> b) -> Order a
             -> (a, PQ.PrimQuery, T.Tag) -> (a, PQ.PrimQuery, T.Tag)
distinctOnBy :: Unpackspec b b
-> (a -> b)
-> Order a
-> (a, PrimQuery, Tag)
-> (a, PrimQuery, Tag)
distinctOnBy Unpackspec b b
ups a -> b
proj Order a
ord (a
cols, PrimQuery
pq, Tag
t) = (a
cols, PrimQuery
pqOut, Tag
t)
    where pqOut :: PrimQuery
pqOut = case [PrimExpr] -> Maybe (NonEmpty PrimExpr)
forall a. [a] -> Maybe (NonEmpty a)
NL.nonEmpty (Unpackspec b b -> b -> [PrimExpr]
forall s t. Unpackspec s t -> s -> [PrimExpr]
U.collectPEs Unpackspec b b
ups (a -> b
proj a
cols)) of
            Just NonEmpty PrimExpr
xs -> Maybe (NonEmpty PrimExpr) -> [OrderExpr] -> PrimQuery -> PrimQuery
forall a.
Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> PrimQuery' a -> PrimQuery' a
PQ.DistinctOnOrderBy (NonEmpty PrimExpr -> Maybe (NonEmpty PrimExpr)
forall a. a -> Maybe a
Just NonEmpty PrimExpr
xs) [OrderExpr]
oexprs PrimQuery
pq
            Maybe (NonEmpty PrimExpr)
Nothing -> LimitOp -> PrimQuery -> PrimQuery
forall a. LimitOp -> PrimQuery' a -> PrimQuery' a
PQ.Limit (Int -> LimitOp
PQ.LimitOp Int
1) (Maybe (NonEmpty PrimExpr) -> [OrderExpr] -> PrimQuery -> PrimQuery
forall a.
Maybe (NonEmpty PrimExpr)
-> [OrderExpr] -> PrimQuery' a -> PrimQuery' a
PQ.DistinctOnOrderBy Maybe (NonEmpty PrimExpr)
forall a. Maybe a
Nothing [OrderExpr]
oexprs PrimQuery
pq)
          oexprs :: [OrderExpr]
oexprs = a -> Order a -> [OrderExpr]
forall a. a -> Order a -> [OrderExpr]
orderExprs a
cols Order a
ord

-- | Order the results of a given query exactly, as determined by the given list
-- of input columns. Note that this list does not have to contain an entry for
-- every result in your query: you may exactly order only a subset of results,
-- if you wish. Rows that are not ordered according to the input list are
-- returned /after/ the ordered results, in the usual order the database would
-- return them (e.g. sorted by primary key). Exactly-ordered results always come
-- first in a result set. Entries in the input list that are /not/ present in
-- result of a query are ignored.
exact :: [IC.Column b] -> (a -> IC.Column b) -> Order a
exact :: [Column b] -> (a -> Column b) -> Order a
exact [Column b]
xs a -> Column b
k = Order a
-> (NonEmpty (Column b) -> Order a)
-> Maybe (NonEmpty (Column b))
-> Order a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Order a
forall a. Monoid a => a
M.mempty NonEmpty (Column b) -> Order a
go ([Column b] -> Maybe (NonEmpty (Column b))
forall a. [a] -> Maybe (NonEmpty a)
NL.nonEmpty [Column b]
xs) where
  -- Create an equality AST node, between two columns, essentially
  -- stating "(column = value)" syntactically.
  mkEq :: Column a -> Column a -> PrimExpr
mkEq  = BinOp -> PrimExpr -> PrimExpr -> PrimExpr
HPQ.BinExpr BinOp
(HPQ.:=) (PrimExpr -> PrimExpr -> PrimExpr)
-> (Column a -> PrimExpr) -> Column a -> Column a -> PrimExpr
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Column a -> PrimExpr
forall a. Column a -> PrimExpr
IC.unColumn

  -- The AST operation: ORDER BY (equalities...) DESC NULLS FIRST
  -- NOTA BENE: DESC is mandatory (otherwise the result is reversed, as you are
  -- "descending" down the list of equalities from the front, rather than
  -- "ascending" from the end of the list.) NULLS FIRST strictly isn't needed;
  -- but HPQ.OrderOp currently mandates a value for both the direction
  -- (OrderDirection) and the rules for null (OrderNulls) values, in the
  -- OrderOp constructor.
  astOp :: OrderOp
astOp = OrderDirection -> OrderNulls -> OrderOp
HPQ.OrderOp OrderDirection
HPQ.OpDesc OrderNulls
HPQ.NullsFirst

  -- Final result: ORDER BY (equalities...) DESC NULLS FIRST, with a given
  -- list of equality operations, created via 'mkEq'
  go :: NonEmpty (Column b) -> Order a
go NonEmpty (Column b)
givenOrder = (a -> [(OrderOp, PrimExpr)]) -> Order a
forall a. (a -> [(OrderOp, PrimExpr)]) -> Order a
Order ((a -> [(OrderOp, PrimExpr)]) -> Order a)
-> (a -> [(OrderOp, PrimExpr)]) -> Order a
forall a b. (a -> b) -> a -> b
$ ((Column b -> [(OrderOp, PrimExpr)])
 -> (a -> Column b) -> a -> [(OrderOp, PrimExpr)])
-> (a -> Column b)
-> (Column b -> [(OrderOp, PrimExpr)])
-> a
-> [(OrderOp, PrimExpr)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Column b -> [(OrderOp, PrimExpr)])
-> (a -> Column b) -> a -> [(OrderOp, PrimExpr)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Column b
k ((Column b -> [(OrderOp, PrimExpr)]) -> a -> [(OrderOp, PrimExpr)])
-> (Column b -> [(OrderOp, PrimExpr)])
-> a
-> [(OrderOp, PrimExpr)]
forall a b. (a -> b) -> a -> b
$ \Column b
col ->
    [(OrderOp
astOp, NonEmpty PrimExpr -> PrimExpr
HPQ.ListExpr (NonEmpty PrimExpr -> PrimExpr) -> NonEmpty PrimExpr -> PrimExpr
forall a b. (a -> b) -> a -> b
$ (Column b -> PrimExpr) -> NonEmpty (Column b) -> NonEmpty PrimExpr
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NL.map (Column b -> Column b -> PrimExpr
forall a. Column a -> Column a -> PrimExpr
mkEq Column b
col) NonEmpty (Column b)
givenOrder)]