{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Manual construction of sorting spec.
module Servant.Util.Combinators.Sorting.Construction
    ( SortingRequestItem
    , asc, desc
    , mkSortingSpec
    , noSorting
    ) where

import Universum

import Data.Default (Default (..))
import GHC.Exts (IsList (..))
import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError)

import Servant.Util.Combinators.Sorting.Base
import Servant.Util.Common


-- | Helper for defining custom 'SortingSpec's,
-- contains 'SortingItem' corresponding to one of parameter in @provided@ list.
newtype SortingRequestItem (provided :: [TyNamedParam *]) = SortingRequestItem
    { SortingRequestItem provided -> SortingItem
unSortingRequestItem :: SortingItem
    } deriving (Int -> SortingRequestItem provided -> ShowS
[SortingRequestItem provided] -> ShowS
SortingRequestItem provided -> String
(Int -> SortingRequestItem provided -> ShowS)
-> (SortingRequestItem provided -> String)
-> ([SortingRequestItem provided] -> ShowS)
-> Show (SortingRequestItem provided)
forall (provided :: [TyNamedParam *]).
Int -> SortingRequestItem provided -> ShowS
forall (provided :: [TyNamedParam *]).
[SortingRequestItem provided] -> ShowS
forall (provided :: [TyNamedParam *]).
SortingRequestItem provided -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SortingRequestItem provided] -> ShowS
$cshowList :: forall (provided :: [TyNamedParam *]).
[SortingRequestItem provided] -> ShowS
show :: SortingRequestItem provided -> String
$cshow :: forall (provided :: [TyNamedParam *]).
SortingRequestItem provided -> String
showsPrec :: Int -> SortingRequestItem provided -> ShowS
$cshowsPrec :: forall (provided :: [TyNamedParam *]).
Int -> SortingRequestItem provided -> ShowS
Show)

type family KnownTypeName
    (origProvided :: [TyNamedParam *])
    (name :: Symbol)
    (provided :: [TyNamedParam *])
        :: Constraint where
    KnownTypeName orig name '[] =
        TypeError ('Text "Parameter " ':<>: 'ShowType name ':<>: 'Text " is not allowed here"
                   ':$$: 'Text "Available fields to sort on: " ':<>:
                         'ShowType (TyNamedParamsNames orig))
    KnownTypeName _ name ('TyNamedParam name _ ': _) = (KnownSymbol name)
    KnownTypeName orig name ('TyNamedParam name0 _ ': provided) = KnownTypeName orig name provided

-- | Ascendant sorting on a field with given name.
asc
    :: forall name provided.
       (KnownSymbol name, KnownTypeName provided name provided)
    => NameLabel name -> SortingRequestItem provided
asc :: NameLabel name -> SortingRequestItem provided
asc NameLabel name
_ = SortingItem -> SortingRequestItem provided
forall (provided :: [TyNamedParam *]).
SortingItem -> SortingRequestItem provided
SortingRequestItem SortingItem :: Text -> SortingOrder -> SortingItem
SortingItem
      { siName :: Text
siName = KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name
      , siOrder :: SortingOrder
siOrder = SortingOrder
Ascendant
      }

-- | Ascendant sorting on a field with given name.
desc
    :: forall name provided.
       (KnownSymbol name, KnownTypeName provided name provided)
    => NameLabel name -> SortingRequestItem provided
desc :: NameLabel name -> SortingRequestItem provided
desc NameLabel name
_ = SortingItem -> SortingRequestItem provided
forall (provided :: [TyNamedParam *]).
SortingItem -> SortingRequestItem provided
SortingRequestItem SortingItem :: Text -> SortingOrder -> SortingItem
SortingItem
      { siName :: Text
siName = KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name
      , siOrder :: SortingOrder
siOrder = SortingOrder
Descendant
      }

-- | Instance for 'SortingSpec' construction.
instance ReifySortingItems base => IsList (SortingSpec provided base) where
    type Item (SortingSpec provided base) = SortingRequestItem provided
    toList :: SortingSpec provided base -> [Item (SortingSpec provided base)]
toList = (SortingItem -> SortingRequestItem provided)
-> [SortingItem] -> [SortingRequestItem provided]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SortingItem -> SortingRequestItem provided
forall (provided :: [TyNamedParam *]).
SortingItem -> SortingRequestItem provided
SortingRequestItem ([SortingItem] -> [SortingRequestItem provided])
-> (SortingSpec provided base -> [SortingItem])
-> SortingSpec provided base
-> [SortingRequestItem provided]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SortingSpec provided base -> [SortingItem]
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)]).
SortingSpec provided base -> [SortingItem]
ssProvided
    fromList :: [Item (SortingSpec provided base)] -> SortingSpec provided base
fromList = [SortingItem] -> SortingSpec provided base
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)]).
ReifySortingItems base =>
[SortingItem] -> SortingSpec provided base
SortingSpec ([SortingItem] -> SortingSpec provided base)
-> ([SortingRequestItem provided] -> [SortingItem])
-> [SortingRequestItem provided]
-> SortingSpec provided base
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SortingRequestItem provided -> SortingItem)
-> [SortingRequestItem provided] -> [SortingItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map SortingRequestItem provided -> SortingItem
forall (provided :: [TyNamedParam *]).
SortingRequestItem provided -> SortingItem
unSortingRequestItem

{- | Make a sorting specification.
Specified list should contain sorting on distinct fields; we do not enforce this
at type-level for convenience.

Example:

@
-- {-# LANGUAGE OverloadedLabels #-}

sortingSpec :: SortingSpec ["id" ?: Int, "desc" ?: Text]
sortingSpec = mkSortingSpec [asc #id]
@

-}
mkSortingSpec
    :: ReifySortingItems base
    => [SortingRequestItem provided] -> SortingSpec provided base
mkSortingSpec :: [SortingRequestItem provided] -> SortingSpec provided base
mkSortingSpec = [SortingRequestItem provided] -> SortingSpec provided base
forall l. IsList l => [Item l] -> l
fromList

-- | By default 'noSorting' is used.
instance ReifySortingItems base => Default (SortingSpec provided base) where
    def :: SortingSpec provided base
def = SortingSpec provided base
forall (base :: [TyNamedParam (SortingOrderType *)])
       (provided :: [TyNamedParam *]).
ReifySortingItems base =>
SortingSpec provided base
noSorting

-- | Do not specify ordering.
noSorting :: ReifySortingItems base => SortingSpec provided base
noSorting :: SortingSpec provided base
noSorting = [SortingRequestItem provided] -> SortingSpec provided base
forall (base :: [TyNamedParam (SortingOrderType *)])
       (provided :: [TyNamedParam *]).
ReifySortingItems base =>
[SortingRequestItem provided] -> SortingSpec provided base
mkSortingSpec []