module Servant.Util.Combinators.Sorting.Base
    ( SortingParams
    , SortParamsExpanded
    , SortingSpec (..)
    , ssBase
    , ssAll
    , SortingOrder (..)
    , NullsSortingOrder (..)
    , SortingItemTagged (..)
    , SortingItem (..)
    , TaggedSortingItemsList
    , SortingOrderType (..)
    , ReifySortingItems (..)
    , BaseSortingToParam
    , AllSortingParams
    , SortingParamProvidedOf
    , SortingParamBaseOf
    , SortingParamsOf
    , SortingSpecOf
    ) where

import Universum

import Data.List (nubBy)
import Fmt (Buildable (..))
import GHC.TypeLits (KnownSymbol)
import Servant (QueryParam, (:>))
import Servant.API (NoContent)
import Servant.Server (Tagged (..))
import Servant.Util.Common
import qualified Text.Show

{- | Servant API combinator which allows to accept sorting parameters as a query parameter.

Example: with the following combinator

@
SortingParams ["time" ?: Timestamp, "name" ?: Text] '[]
@

the endpoint can parse "sortBy=-time,+name" or "sortBy=desc(time),asc(name)" formats,
which would mean sorting by mentioned fields lexicographically. All sorting
subparameters are optional, as well as entire "sortBy" parameter.

The second type-level list stands for the base sorting order, it will be applied
in the end disregard the user's input.
It is highly recommended to specify the base sorting that unambigously orders the
result(for example - by the primary key of the database), otherwise pagination
may behave unexpectedly for the client when it specifies no sorting.

If you want the base sorting order to be overridable by the user, you can
put the respective fields in both lists. For example, this combinator:

@
SortingParams
  '["time" ?: Timestamp]
   ["id" ?: '(Id, 'Descendant), "time" ?: '(Timestamp, 'Ascendant)]
@

will sort results lexicographically by @(Down id, time)@, but if the client
specifies sorting by time, you will get sorting by @(time, Down id)@ as the
trailing @"time"@ will not affect anything.

It is preferred to put a base sorting at least by @ID@, this way results will be
more deterministic.

Your handler will be provided with 'SortingSpec' argument which can later be passed
in an appropriate function to perform sorting.
-}
data SortingParams
  (provided :: [TyNamedParam *])
  (base :: [TyNamedParam (SortingOrderType *)])

-- | How servant sees 'SortParams' under the hood.
type SortParamsExpanded allowed subApi =
    QueryParam "sortBy" (TaggedSortingItemsList allowed) :> subApi

-- | Order of sorting.
data SortingOrder
    = Descendant
    | Ascendant
    deriving (Int -> SortingOrder -> ShowS
[SortingOrder] -> ShowS
SortingOrder -> String
(Int -> SortingOrder -> ShowS)
-> (SortingOrder -> String)
-> ([SortingOrder] -> ShowS)
-> Show SortingOrder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SortingOrder] -> ShowS
$cshowList :: [SortingOrder] -> ShowS
show :: SortingOrder -> String
$cshow :: SortingOrder -> String
showsPrec :: Int -> SortingOrder -> ShowS
$cshowsPrec :: Int -> SortingOrder -> ShowS
Show, SortingOrder -> SortingOrder -> Bool
(SortingOrder -> SortingOrder -> Bool)
-> (SortingOrder -> SortingOrder -> Bool) -> Eq SortingOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SortingOrder -> SortingOrder -> Bool
$c/= :: SortingOrder -> SortingOrder -> Bool
== :: SortingOrder -> SortingOrder -> Bool
$c== :: SortingOrder -> SortingOrder -> Bool
Eq, Int -> SortingOrder
SortingOrder -> Int
SortingOrder -> [SortingOrder]
SortingOrder -> SortingOrder
SortingOrder -> SortingOrder -> [SortingOrder]
SortingOrder -> SortingOrder -> SortingOrder -> [SortingOrder]
(SortingOrder -> SortingOrder)
-> (SortingOrder -> SortingOrder)
-> (Int -> SortingOrder)
-> (SortingOrder -> Int)
-> (SortingOrder -> [SortingOrder])
-> (SortingOrder -> SortingOrder -> [SortingOrder])
-> (SortingOrder -> SortingOrder -> [SortingOrder])
-> (SortingOrder -> SortingOrder -> SortingOrder -> [SortingOrder])
-> Enum SortingOrder
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SortingOrder -> SortingOrder -> SortingOrder -> [SortingOrder]
$cenumFromThenTo :: SortingOrder -> SortingOrder -> SortingOrder -> [SortingOrder]
enumFromTo :: SortingOrder -> SortingOrder -> [SortingOrder]
$cenumFromTo :: SortingOrder -> SortingOrder -> [SortingOrder]
enumFromThen :: SortingOrder -> SortingOrder -> [SortingOrder]
$cenumFromThen :: SortingOrder -> SortingOrder -> [SortingOrder]
enumFrom :: SortingOrder -> [SortingOrder]
$cenumFrom :: SortingOrder -> [SortingOrder]
fromEnum :: SortingOrder -> Int
$cfromEnum :: SortingOrder -> Int
toEnum :: Int -> SortingOrder
$ctoEnum :: Int -> SortingOrder
pred :: SortingOrder -> SortingOrder
$cpred :: SortingOrder -> SortingOrder
succ :: SortingOrder -> SortingOrder
$csucc :: SortingOrder -> SortingOrder
Enum)

-- | Where to place null fields.
data NullsSortingOrder
    = NullsFirst
    | NullsLast
    deriving (Int -> NullsSortingOrder -> ShowS
[NullsSortingOrder] -> ShowS
NullsSortingOrder -> String
(Int -> NullsSortingOrder -> ShowS)
-> (NullsSortingOrder -> String)
-> ([NullsSortingOrder] -> ShowS)
-> Show NullsSortingOrder
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NullsSortingOrder] -> ShowS
$cshowList :: [NullsSortingOrder] -> ShowS
show :: NullsSortingOrder -> String
$cshow :: NullsSortingOrder -> String
showsPrec :: Int -> NullsSortingOrder -> ShowS
$cshowsPrec :: Int -> NullsSortingOrder -> ShowS
Show, NullsSortingOrder -> NullsSortingOrder -> Bool
(NullsSortingOrder -> NullsSortingOrder -> Bool)
-> (NullsSortingOrder -> NullsSortingOrder -> Bool)
-> Eq NullsSortingOrder
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NullsSortingOrder -> NullsSortingOrder -> Bool
$c/= :: NullsSortingOrder -> NullsSortingOrder -> Bool
== :: NullsSortingOrder -> NullsSortingOrder -> Bool
$c== :: NullsSortingOrder -> NullsSortingOrder -> Bool
Eq, Int -> NullsSortingOrder
NullsSortingOrder -> Int
NullsSortingOrder -> [NullsSortingOrder]
NullsSortingOrder -> NullsSortingOrder
NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
NullsSortingOrder
-> NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
(NullsSortingOrder -> NullsSortingOrder)
-> (NullsSortingOrder -> NullsSortingOrder)
-> (Int -> NullsSortingOrder)
-> (NullsSortingOrder -> Int)
-> (NullsSortingOrder -> [NullsSortingOrder])
-> (NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder])
-> (NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder])
-> (NullsSortingOrder
    -> NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder])
-> Enum NullsSortingOrder
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: NullsSortingOrder
-> NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
$cenumFromThenTo :: NullsSortingOrder
-> NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
enumFromTo :: NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
$cenumFromTo :: NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
enumFromThen :: NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
$cenumFromThen :: NullsSortingOrder -> NullsSortingOrder -> [NullsSortingOrder]
enumFrom :: NullsSortingOrder -> [NullsSortingOrder]
$cenumFrom :: NullsSortingOrder -> [NullsSortingOrder]
fromEnum :: NullsSortingOrder -> Int
$cfromEnum :: NullsSortingOrder -> Int
toEnum :: Int -> NullsSortingOrder
$ctoEnum :: Int -> NullsSortingOrder
pred :: NullsSortingOrder -> NullsSortingOrder
$cpred :: NullsSortingOrder -> NullsSortingOrder
succ :: NullsSortingOrder -> NullsSortingOrder
$csucc :: NullsSortingOrder -> NullsSortingOrder
Enum)

-- | For a given field, user-supplied order of sorting.
-- This type is primarly for internal use, see also 'SortingItemTagged'.
data SortingItem = SortingItem
    { SortingItem -> Text
siName  :: Text
      -- ^ Name of parameter.
      -- Always matches one in @param@, but we keep it at term-level as well for convenience.
    , SortingItem -> SortingOrder
siOrder :: SortingOrder
      -- ^ Sorting order on the given parameter.

    -- , siNullsOrder :: Maybe NullsSortingOrder
      ---- ^ Order of null fields.
      ---- Present only when the second element in @param@ tuple is 'Maybe'.
      ---- TODO [DSCP-425] add support for this
    } deriving (Int -> SortingItem -> ShowS
[SortingItem] -> ShowS
SortingItem -> String
(Int -> SortingItem -> ShowS)
-> (SortingItem -> String)
-> ([SortingItem] -> ShowS)
-> Show SortingItem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SortingItem] -> ShowS
$cshowList :: [SortingItem] -> ShowS
show :: SortingItem -> String
$cshow :: SortingItem -> String
showsPrec :: Int -> SortingItem -> ShowS
$cshowsPrec :: Int -> SortingItem -> ShowS
Show)

-- | Version 'SortingItem' which remembers its name and parameter type at type level.
-- In functions which belong to public API you will most probably want to use this datatype
-- as a safer variant of 'SortingItem'.
newtype SortingItemTagged (provided :: TyNamedParam *) = SortingItemTagged
    { SortingItemTagged provided -> SortingItem
untagSortingItem :: SortingItem
    } deriving (Int -> SortingItemTagged provided -> ShowS
[SortingItemTagged provided] -> ShowS
SortingItemTagged provided -> String
(Int -> SortingItemTagged provided -> ShowS)
-> (SortingItemTagged provided -> String)
-> ([SortingItemTagged provided] -> ShowS)
-> Show (SortingItemTagged provided)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (provided :: TyNamedParam *).
Int -> SortingItemTagged provided -> ShowS
forall (provided :: TyNamedParam *).
[SortingItemTagged provided] -> ShowS
forall (provided :: TyNamedParam *).
SortingItemTagged provided -> String
showList :: [SortingItemTagged provided] -> ShowS
$cshowList :: forall (provided :: TyNamedParam *).
[SortingItemTagged provided] -> ShowS
show :: SortingItemTagged provided -> String
$cshow :: forall (provided :: TyNamedParam *).
SortingItemTagged provided -> String
showsPrec :: Int -> SortingItemTagged provided -> ShowS
$cshowsPrec :: forall (provided :: TyNamedParam *).
Int -> SortingItemTagged provided -> ShowS
Show)

instance Buildable SortingItem where
    build :: SortingItem -> Builder
build SortingItem{Text
SortingOrder
siOrder :: SortingOrder
siName :: Text
siOrder :: SortingItem -> SortingOrder
siName :: SortingItem -> Text
..} =
        let order :: Builder
order = case SortingOrder
siOrder of { SortingOrder
Ascendant -> Builder
"⯅ "; SortingOrder
Descendant -> Builder
"⯆ " }
        in Builder
order Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
siName

deriving instance Buildable (SortingItemTagged param)

-- | Tagged, because we want to retain list of allowed fields for parsing
-- (in @instance FromHttpApiData@).
type TaggedSortingItemsList provided = Tagged (provided :: [TyNamedParam *]) [SortingItem]

-- | Order of sorting for type-level.
--
-- Its constructors accept the type of thing we order by, e.g. @Asc Id@.
data SortingOrderType k
    = Desc k
    | Asc k

-- | What is passed to an endpoint, contains all sorting parameters provided by a user.
{- Following properties hold:
1. Each entry in the underlying list has a unique name ('siName' field).
2. Entries correspond to @params@ type, i.e. any 'SortingItem' entry of the underlying
list with name "N" will be present in @params@.

Not all parameters specified by @params@ phantom type can be present, e.g. the underlying
list will be empty if user didn't pass "sortBy" query parameter at all. However,
entries from the base sorting are always present.
-}
data SortingSpec
  (provided :: [TyNamedParam *])
  (base :: [TyNamedParam (SortingOrderType *)]) =
    ReifySortingItems base =>
    SortingSpec
    { SortingSpec provided base -> [SortingItem]
ssProvided :: [SortingItem]
      -- ^ Sorting items provided by the user (lexicographical order).
    }

instance Show (SortingSpec provided base) where
    show :: SortingSpec provided base -> String
show SortingSpec provided base
s =
        String
"SortingSpec {ssProvided = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [SortingItem] -> String
forall b a. (Show a, IsString b) => a -> b
show (SortingSpec provided base -> [SortingItem]
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)]).
SortingSpec provided base -> [SortingItem]
ssProvided SortingSpec provided base
s) String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                   String
", ssBase = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [SortingItem] -> String
forall b a. (Show a, IsString b) => a -> b
show (SortingSpec provided base -> [SortingItem]
forall (base :: [TyNamedParam (SortingOrderType *)])
       (provided :: [TyNamedParam *]).
SortingSpec provided base -> [SortingItem]
ssBase SortingSpec provided base
s) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"}"

-- | Base sorting items, that are present disregard the client's input
-- (lexicographical order).
--
-- This is a sort of virtual field, so such naming.
ssBase :: forall base provided. SortingSpec provided base -> [SortingItem]
ssBase :: SortingSpec provided base -> [SortingItem]
ssBase SortingSpec{} = ReifySortingItems base => [SortingItem]
forall (items :: [TyNamedParam (SortingOrderType *)]).
ReifySortingItems items =>
[SortingItem]
reifySortingItems @base

-- | Requires given type-level items to be valid specification of sorting.
class ReifySortingItems (items :: [TyNamedParam (SortingOrderType *)]) where
    reifySortingItems :: [SortingItem]

instance ReifySortingItems '[] where
    reifySortingItems :: [SortingItem]
reifySortingItems = []

instance ( ReifySortingOrder order, KnownSymbol name
         , ReifySortingItems items
         ) => ReifySortingItems ('TyNamedParam name (order field) ': items) where
    reifySortingItems :: [SortingItem]
reifySortingItems =
        SortingItem :: Text -> SortingOrder -> SortingItem
SortingItem
        { siName :: Text
siName = KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name
        , siOrder :: SortingOrder
siOrder = ReifySortingOrder order => SortingOrder
forall (order :: * -> SortingOrderType *).
ReifySortingOrder order =>
SortingOrder
reifySortingOrder @order
        } SortingItem -> [SortingItem] -> [SortingItem]
forall a. a -> [a] -> [a]
: ReifySortingItems items => [SortingItem]
forall (items :: [TyNamedParam (SortingOrderType *)]).
ReifySortingItems items =>
[SortingItem]
reifySortingItems @items

class ReifySortingOrder (order :: * -> SortingOrderType *) where
    reifySortingOrder :: SortingOrder

instance ReifySortingOrder 'Asc where
    reifySortingOrder :: SortingOrder
reifySortingOrder = SortingOrder
Ascendant

instance ReifySortingOrder 'Desc where
    reifySortingOrder :: SortingOrder
reifySortingOrder = SortingOrder
Descendant

-- | All sorting items with duplicates removed (lexicographical order).
ssAll :: SortingSpec provided base -> [SortingItem]
ssAll :: SortingSpec provided base -> [SortingItem]
ssAll SortingSpec provided base
s = (SortingItem -> SortingItem -> Bool)
-> [SortingItem] -> [SortingItem]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool)
-> (SortingItem -> Text) -> SortingItem -> SortingItem -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SortingItem -> Text
siName) (SortingSpec provided base -> [SortingItem]
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)]).
SortingSpec provided base -> [SortingItem]
ssProvided SortingSpec provided base
s [SortingItem] -> [SortingItem] -> [SortingItem]
forall a. Semigroup a => a -> a -> a
<> SortingSpec provided base -> [SortingItem]
forall (base :: [TyNamedParam (SortingOrderType *)])
       (provided :: [TyNamedParam *]).
SortingSpec provided base -> [SortingItem]
ssBase SortingSpec provided base
s)

-- | Maps @base@ params to the form common for @provided@ and @base@.
type family BaseSortingToParam (base :: [TyNamedParam (SortingOrderType *)])
  :: [TyNamedParam *] where
    BaseSortingToParam '[] = '[]
    BaseSortingToParam ('TyNamedParam name (order field) ': xs) =
      'TyNamedParam name field ': BaseSortingToParam xs

-- | All sorting params, provided + base.
--
-- This does not yet remove duplicates from @provided@ and @base@ sets,
-- we wait for specific use cases to decide how to handle this better.
type family AllSortingParams
  (provided :: [TyNamedParam *])
  (base :: [TyNamedParam (SortingOrderType *)])
  :: [TyNamedParam *] where
    AllSortingParams provided base = provided ++ BaseSortingToParam base

-- | For a given return type of an endpoint get corresponding sorting params
-- that can be specified by user.
-- This mapping is sensible, since we usually allow to sort only on fields appearing in
-- endpoint's response.
type family SortingParamProvidedOf a :: [TyNamedParam *]

-- | For a given return type of an endpoint get corresponding base sorting params.
type family SortingParamBaseOf a :: [TyNamedParam (SortingOrderType *)]

-- | This you will most probably want to specify in API.
type SortingParamsOf a = SortingParams (SortingParamProvidedOf a) (SortingParamBaseOf a)

-- | This you will most probably want to specify in an endpoint implementation.
type SortingSpecOf a = SortingSpec (SortingParamProvidedOf a) (SortingParamBaseOf a)

type instance SortingParamBaseOf NoContent = '[]
type instance SortingParamProvidedOf NoContent = '[]