-- | Applying sorting specifications.
module Servant.Util.Combinators.Sorting.Backend
    ( SortingBackend (..)
    , fieldSort
    , SortingApp (..)
    , SortingSpecApp

    , ApplyToSortItem (..)
    , backendApplySorting
    ) where

import Universum

import GHC.TypeLits (KnownSymbol)

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

-- | Implementation of filtering backend.
class SortingBackend backend where

    -- | The part of object which we are filtering on,
    -- provided by server backend implementor.
    type SortedValue backend a :: *

    -- | What we require from sorted values in order to be sortable.
    type SortedValueConstraint backend a :: Constraint
    type SortedValueConstraint backend a = ()

    -- | A resulting ordering.
    type BackendOrdering backend :: *

    -- | Implement 'SortingApp' as sorting on the given field.
    backendFieldSort
        :: SortedValueConstraint backend a
        => SortedValue backend a
        -> SortingApp backend ('TyNamedParam name a)

fieldSort
    :: forall name a backend.
       (SortingBackend backend, SortedValueConstraint backend a)
    => SortedValue backend a -> SortingApp backend ('TyNamedParam name a)
fieldSort :: SortedValue backend a -> SortingApp backend ('TyNamedParam name a)
fieldSort = SortedValue backend a -> SortingApp backend ('TyNamedParam name a)
forall backend a (name :: Symbol).
(SortingBackend backend, SortedValueConstraint backend a) =>
SortedValue backend a -> SortingApp backend ('TyNamedParam name a)
backendFieldSort

-- | A function defining a way to apply the given 'SortingItem' (which is sorting
-- order on a single parameter).
newtype SortingApp backend param
    = SortingApp (SortingItemTagged param -> BackendOrdering backend)

{- | List of 'SortingApp' functions. Describes how to apply @SortingSpec params@
(each of possible 'SortingItem') to an SQL query.

Instance of this type can be created using 'fieldSort' function. For example:

@
sortingSpecApp :: SortingSpecApp ["course" ?: Course, "desc" ?: Text]
sortingSpecApp =
    fieldSort @"course" courseField .*.
    fieldSort @"desc" descField .*.
    HNil
@

Annotating 'fieldSort' call with parameter name is not mandatory but recommended
to prevent possible mistakes in 'fieldSort's ordering.
-}
type SortingSpecApp backend (allParams :: [TyNamedParam *]) =
    HList (SortingApp backend) allParams

-- | Lookup for appropriate 'SortingApp' in 'SortingSpecApp' and apply it to 'SortingItem'.
class ApplyToSortItem backend params where
    -- | Apply spec app to the given 'SortingItem'
    -- We return 'Maybe' here (instead of forcing presence at type-level) for convenience.
    applyToSortItem
        :: SortingSpecApp backend params
        -> SortingItem
        -> Maybe (BackendOrdering backend)

instance ApplyToSortItem backend '[] where
    applyToSortItem :: SortingSpecApp backend '[]
-> SortingItem -> Maybe (BackendOrdering backend)
applyToSortItem SortingSpecApp backend '[]
HNil SortingItem
_ = Maybe (BackendOrdering backend)
forall a. Maybe a
Nothing

instance (KnownSymbol name, ApplyToSortItem backend params) =>
         ApplyToSortItem backend ('TyNamedParam name p ': params) where
    applyToSortItem :: SortingSpecApp backend ('TyNamedParam name p : params)
-> SortingItem -> Maybe (BackendOrdering backend)
applyToSortItem (SortingApp SortingItemTagged a -> BackendOrdering backend
app `HCons` HList (SortingApp backend) as
appRem) SortingItem
item = [Maybe (BackendOrdering backend)]
-> Maybe (BackendOrdering backend)
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
        [ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT @name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== SortingItem -> Text
siName SortingItem
item) Maybe ()
-> BackendOrdering backend -> Maybe (BackendOrdering backend)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SortingItemTagged a -> BackendOrdering backend
app (SortingItem -> SortingItemTagged a
forall (provided :: TyNamedParam *).
SortingItem -> SortingItemTagged provided
SortingItemTagged SortingItem
item)
        , SortingSpecApp backend params
-> SortingItem -> Maybe (BackendOrdering backend)
forall backend (params :: [TyNamedParam *]).
ApplyToSortItem backend params =>
SortingSpecApp backend params
-> SortingItem -> Maybe (BackendOrdering backend)
applyToSortItem @backend @params SortingSpecApp backend params
HList (SortingApp backend) as
appRem SortingItem
item
        ]

-- | Apply a given 'SortingSpecApp' to a 'SortingSpec' producing a pack of
-- ordering values which define lexicographical sorting order.
backendApplySorting
    :: forall provided base allParams backend.
       ( allParams ~ AllSortingParams provided base
       , ApplyToSortItem backend allParams
       )
    => SortingSpec provided base
    -> SortingSpecApp backend allParams
    -> [BackendOrdering backend]
backendApplySorting :: SortingSpec provided base
-> SortingSpecApp backend allParams -> [BackendOrdering backend]
backendApplySorting SortingSpec provided base
spec SortingSpecApp backend allParams
app =
    SortingSpec provided base -> [SortingItem]
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)]).
SortingSpec provided base -> [SortingItem]
ssAll SortingSpec provided base
spec [SortingItem]
-> (SortingItem -> BackendOrdering backend)
-> [BackendOrdering backend]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \SortingItem
sitem ->
        SortingSpecApp backend allParams
-> SortingItem -> Maybe (BackendOrdering backend)
forall backend (params :: [TyNamedParam *]).
ApplyToSortItem backend params =>
SortingSpecApp backend params
-> SortingItem -> Maybe (BackendOrdering backend)
applyToSortItem @backend @allParams SortingSpecApp backend allParams
app SortingItem
sitem
           -- impossible due to invariants of 'SortingSpec'
        Maybe (BackendOrdering backend)
-> BackendOrdering backend -> BackendOrdering backend
forall a. Maybe a -> a -> a
?: Text -> BackendOrdering backend
forall a. HasCallStack => Text -> a
error (Text
"Impossible: don't know how to apply to spec item " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SortingItem -> Text
forall b a. (Show a, IsString b) => a -> b
show SortingItem
sitem)