{- | Implements plain lexicographical sorting.

Example:

@
sortingSpecApp
    :: MyObject
    -> SortingSpecApp
        DummySortingBackend
        [ "id" ?: Int
        , "desc" ?: Text
        ]
sortingSpecApp obj =
    fieldSort @"id" (id obj) .*.
    fieldSort @"desc" (desc obj) .*.
    HNil
@

Next, you use `sortBySpec` to apply sorting.

@
sortObjects sorting = filter (sortBySpec sorting . sortingSpecApp) allObjects
@

-}
module Servant.Util.Dummy.Sorting
    ( SortingSpecApp
    , fieldSort
    , sortBySpec
    ) where

import Universum

import Data.Typeable (cast)

import Servant.Util.Combinators.Sorting.Backend
import Servant.Util.Combinators.Sorting.Base

-- | Implements sorting for beam-postgres package.
data DummySortingBackend

data SomeOrd = forall a. (Typeable a, Ord a) => SomeOrd a

-- | Unsafe instance which assumes that 'SomeOrd' contains the same items inside.
instance Eq SomeOrd where
    == :: SomeOrd -> SomeOrd -> Bool
(==) = (Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ) (Ordering -> Bool)
-> (SomeOrd -> SomeOrd -> Ordering) -> SomeOrd -> SomeOrd -> Bool
forall a b c. SuperComposition a b c => a -> b -> c
... SomeOrd -> SomeOrd -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

-- | Unsafe instance which assumes that 'SomeOrd' contains the same items inside.
instance Ord SomeOrd where
    SomeOrd a
a compare :: SomeOrd -> SomeOrd -> Ordering
`compare` SomeOrd a
b =
        let b' :: a
b' = a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
b Maybe a -> a -> a
forall a. Maybe a -> a -> a
?: Text -> a
forall a. HasCallStack => Text -> a
error Text
"Compared `SomeOrd`s are different inside"
        in a
a a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
b'

instance SortingBackend DummySortingBackend where
    type SortedValue DummySortingBackend a = a
    type BackendOrdering DummySortingBackend = SomeOrd

    type SortedValueConstraint DummySortingBackend a = (Typeable a, Ord a)

    backendFieldSort :: SortedValue DummySortingBackend a
-> SortingApp DummySortingBackend ('TyNamedParam name a)
backendFieldSort SortedValue DummySortingBackend a
field = (SortingItemTagged ('TyNamedParam name a)
 -> BackendOrdering DummySortingBackend)
-> SortingApp DummySortingBackend ('TyNamedParam name a)
forall backend (param :: TyNamedParam *).
(SortingItemTagged param -> BackendOrdering backend)
-> SortingApp backend param
SortingApp ((SortingItemTagged ('TyNamedParam name a)
  -> BackendOrdering DummySortingBackend)
 -> SortingApp DummySortingBackend ('TyNamedParam name a))
-> (SortingItemTagged ('TyNamedParam name a)
    -> BackendOrdering DummySortingBackend)
-> SortingApp DummySortingBackend ('TyNamedParam name a)
forall a b. (a -> b) -> a -> b
$ \(SortingItemTagged (SortingItem Text
_name SortingOrder
order)) ->
        case SortingOrder
order of
            SortingOrder
Ascendant  -> a -> SomeOrd
forall a. (Typeable a, Ord a) => a -> SomeOrd
SomeOrd a
SortedValue DummySortingBackend a
field
            SortingOrder
Descendant -> Down a -> SomeOrd
forall a. (Typeable a, Ord a) => a -> SomeOrd
SomeOrd (a -> Down a
forall a. a -> Down a
Down a
SortedValue DummySortingBackend a
field)

-- | Applies a whole filtering specification to a set of response fields.
-- Resulting value can be put to 'filter' function.
sortBySpec
    :: ( backend ~ DummySortingBackend
       , allParams ~ AllSortingParams provided base
       , ApplyToSortItem backend allParams
       )
    => SortingSpec provided base
    -> (a -> SortingSpecApp backend allParams)
    -> [a] -> [a]
sortBySpec :: SortingSpec provided base
-> (a -> SortingSpecApp backend allParams) -> [a] -> [a]
sortBySpec SortingSpec provided base
spec a -> SortingSpecApp backend allParams
mkApp [a]
values =
    ((a, [SomeOrd]) -> a) -> [(a, [SomeOrd])] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (a, [SomeOrd]) -> a
forall a b. (a, b) -> a
fst ([(a, [SomeOrd])] -> [a])
-> ([(a, [SomeOrd])] -> [(a, [SomeOrd])])
-> [(a, [SomeOrd])]
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, [SomeOrd]) -> [SomeOrd])
-> [(a, [SomeOrd])] -> [(a, [SomeOrd])]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (a, [SomeOrd]) -> [SomeOrd]
forall a b. (a, b) -> b
snd ([(a, [SomeOrd])] -> [a]) -> [(a, [SomeOrd])] -> [a]
forall a b. (a -> b) -> a -> b
$
    (a -> (a, [SomeOrd])) -> [a] -> [(a, [SomeOrd])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (a -> a
forall a. a -> a
id (a -> a) -> (a -> [SomeOrd]) -> a -> (a, [SomeOrd])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SortingSpec provided base
-> SortingSpecApp backend allParams -> [BackendOrdering backend]
forall (provided :: [TyNamedParam *])
       (base :: [TyNamedParam (SortingOrderType *)])
       (allParams :: [TyNamedParam *]) backend.
(allParams ~ AllSortingParams provided base,
 ApplyToSortItem backend allParams) =>
SortingSpec provided base
-> SortingSpecApp backend allParams -> [BackendOrdering backend]
backendApplySorting SortingSpec provided base
spec (SortingSpecApp backend allParams -> [SomeOrd])
-> (a -> SortingSpecApp backend allParams) -> a -> [SomeOrd]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SortingSpecApp backend allParams
mkApp) [a]
values