{-# LANGUAGE TypeInType #-}

-- | Provides base for filtering backend implementations.
module Servant.Util.Combinators.Filtering.Backend
    ( -- * Filtering backend
      FilterBackend (..)
    , AutoFilterImpl
    , FilteringApp (..)
    , AutoFilterSupport (..)
    , FilteringSpecApp
    , BackendApplySomeFilter
    , typeAutoFiltersSupport
    , backendApplyFilters

      -- * Server backend implementor API
    , filterOn
    , manualFilter
    ) where

import Universum

import Data.Typeable (gcast1)
import GHC.TypeLits (KnownSymbol)

import Servant.Util.Combinators.Filtering.Base
import Servant.Util.Common

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

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

    -- | A resulting predicate.
    type MatchPredicate backend

-- | Implementation of auto filter we provide.
type AutoFilterImpl backend a =
    AutoFilteredValue backend a -> MatchPredicate backend

-- | How to apply a filter - what server backend implementor provides.
data FilteringApp backend param where
    AutoFilteringApp
        :: Typeable a
        => AutoFilteredValue backend a
        -> FilteringApp backend ('TyNamedParam name ('AutoFilter a))
    ManualFilteringApp
        :: Typeable a
        => (a -> MatchPredicate backend)
        -> FilteringApp backend ('TyNamedParam name ('ManualFilter a))

-- | Implementation of given auto filter type for Beam Postgres backend.
class (Typeable filter, FilterBackend backend) =>
      AutoFilterSupport backend filter a where
    -- | Apply given filter to a value.
    autoFilterSupport :: filter a -> AutoFilterImpl backend a

-- | Enlists a way to apply each of supported filters at target application backend.
type FilteringSpecApp backend params =
    HList (FilteringApp backend) params

-------------------------------------------------------------------------
-- Implementation
-------------------------------------------------------------------------

-- | Force a type family to be defined.
-- Primarily for prettier error messages.
type family AreFiltersDefined (a :: [Type -> Type]) :: Constraint where
    AreFiltersDefined '[] = Show (Int -> Int)
    AreFiltersDefined a = ()

-- | Lookup among filters supported for this type and prepare
-- an appropriate one for (deferred) application.
class TypeAutoFiltersSupport' backend (filters :: [Type -> Type]) a where
    typeAutoFiltersSupport' :: SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)

instance TypeAutoFiltersSupport' backend '[] a where
    typeAutoFiltersSupport' :: SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)
typeAutoFiltersSupport' SomeTypeAutoFilter a
_ = Maybe (AutoFilterImpl backend a)
forall a. Maybe a
Nothing

instance ( AutoFilterSupport backend filter a
         , TypeAutoFiltersSupport' backend filters a
         ) =>
         TypeAutoFiltersSupport' backend (filter ': filters) a where
    typeAutoFiltersSupport' :: SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)
typeAutoFiltersSupport' sf :: SomeTypeAutoFilter a
sf@(SomeTypeAutoFilter filter a
filtr) = [Maybe (AutoFilterImpl backend a)]
-> Maybe (AutoFilterImpl backend a)
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
        [ do
          Identity filter a
filter' <- Identity (filter a) -> Maybe (Identity (filter a))
forall k1 k2 (c :: k1 -> *) (t :: k2 -> k1) (t' :: k2 -> k1)
       (a :: k2).
(Typeable t, Typeable t') =>
c (t a) -> Maybe (c (t' a))
gcast1 @_ @_ @filter (filter a -> Identity (filter a)
forall a. a -> Identity a
Identity filter a
filtr)
          AutoFilterImpl backend a -> Maybe (AutoFilterImpl backend a)
forall (m :: * -> *) a. Monad m => a -> m a
return (AutoFilterImpl backend a -> Maybe (AutoFilterImpl backend a))
-> AutoFilterImpl backend a -> Maybe (AutoFilterImpl backend a)
forall a b. (a -> b) -> a -> b
$ filter a -> AutoFilterImpl backend a
forall k (backend :: k) (filter :: * -> *) a.
AutoFilterSupport backend filter a =>
filter a -> AutoFilterImpl backend a
autoFilterSupport @backend filter a
filter'

        , SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)
forall k (backend :: k) (filters :: [* -> *]) a.
TypeAutoFiltersSupport' backend filters a =>
SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)
typeAutoFiltersSupport' @backend @filters SomeTypeAutoFilter a
sf
        ]

type TypeAutoFiltersSupport backend a =
    ( AreFiltersDefined (SupportedFilters a)
    , TypeAutoFiltersSupport' backend (SupportedFilters a) a
    )

-- | Safely choose an appropriate filter from supported ones
-- and prepare it for application.
typeAutoFiltersSupport
    :: forall backend a.
       TypeAutoFiltersSupport backend a
    => SomeTypeAutoFilter a -> AutoFilterImpl backend a
typeAutoFiltersSupport :: SomeTypeAutoFilter a -> AutoFilterImpl backend a
typeAutoFiltersSupport SomeTypeAutoFilter a
filtr =
    SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)
forall k (backend :: k) (filters :: [* -> *]) a.
TypeAutoFiltersSupport' backend filters a =>
SomeTypeAutoFilter a -> Maybe (AutoFilterImpl backend a)
typeAutoFiltersSupport' @backend @(SupportedFilters a) @a SomeTypeAutoFilter a
filtr
    Maybe (AutoFilterImpl backend a)
-> AutoFilterImpl backend a -> AutoFilterImpl backend a
forall a. Maybe a -> a -> a
?: Text -> AutoFilterImpl backend a
forall a. HasCallStack => Text -> a
error Text
"impossible, invariants of SomeTypeFilter are violated"

-- | Apply a filter for a specific type, evaluate whether a value matches or not.
class BackendApplyTypeFilter backend (fk :: Type -> FilterKind Type) a where
    backendApplyTypeFilter
        :: FilteringApp backend ('TyNamedParam name (fk a))
        -> TypeFilter fk a
        -> MatchPredicate backend

instance TypeAutoFiltersSupport backend a =>
         BackendApplyTypeFilter backend 'AutoFilter a where
    backendApplyTypeFilter :: FilteringApp backend ('TyNamedParam name ('AutoFilter a))
-> TypeFilter 'AutoFilter a -> MatchPredicate backend
backendApplyTypeFilter (AutoFilteringApp AutoFilteredValue backend a
field) (TypeAutoFilter SomeTypeAutoFilter a
filtr) =
        SomeTypeAutoFilter a -> AutoFilterImpl backend a
forall k (backend :: k) a.
TypeAutoFiltersSupport backend a =>
SomeTypeAutoFilter a -> AutoFilterImpl backend a
typeAutoFiltersSupport @backend SomeTypeAutoFilter a
filtr AutoFilteredValue backend a
AutoFilteredValue backend a
field

instance BackendApplyTypeFilter backend 'ManualFilter a where
    backendApplyTypeFilter :: FilteringApp backend ('TyNamedParam name ('ManualFilter a))
-> TypeFilter 'ManualFilter a -> MatchPredicate backend
backendApplyTypeFilter (ManualFilteringApp a -> MatchPredicate backend
app) (TypeManualFilter a
val) =
        a -> MatchPredicate backend
app a
a
val

-- | Lookups for an appropriate filter application in a given 'FilteringSpecApp'
-- and applies it to a given filter.
class FilterBackend backend =>
      BackendApplySomeFilter backend (params :: [TyNamedFilter]) where
    backendApplySomeFilter'
        :: FilteringSpecApp backend params
        -> SomeFilter params
        -> Maybe (MatchPredicate backend)

instance FilterBackend backend =>
         BackendApplySomeFilter backend '[] where
    backendApplySomeFilter' :: FilteringSpecApp backend '[]
-> SomeFilter '[] -> Maybe (MatchPredicate backend)
backendApplySomeFilter' FilteringSpecApp backend '[]
_ SomeFilter '[]
_  = Maybe (MatchPredicate backend)
forall a. Maybe a
Nothing

instance ( Typeable fk, Typeable a
         , FilterBackend backend
         , KnownSymbol name
         , BackendApplyTypeFilter backend fk a
         , BackendApplySomeFilter backend params
         ) =>
         BackendApplySomeFilter backend ('TyNamedParam name (fk a) ': params) where
    backendApplySomeFilter' :: FilteringSpecApp backend ('TyNamedParam name (fk a) : params)
-> SomeFilter ('TyNamedParam name (fk a) : params)
-> Maybe (MatchPredicate backend)
backendApplySomeFilter' (FilteringApp backend a
app `HCons` HList (FilteringApp backend) as
fields) (SomeFilter Text
name TypeFilter fk a
filtr) = [Maybe (MatchPredicate backend)] -> Maybe (MatchPredicate backend)
forall t (f :: * -> *) a.
(Container t, Alternative f, Element t ~ f a) =>
t -> f a
asum
        [ do
          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
== Text
name)
          let filtr' :: TypeFilter fk a
filtr' = TypeFilter fk a -> Maybe (TypeFilter fk a)
forall (fk1 :: * -> FilterKind *) a1 (fk2 :: * -> FilterKind *) a2.
(Typeable fk1, Typeable a1, Typeable fk2, Typeable a2) =>
TypeFilter fk1 a1 -> Maybe (TypeFilter fk2 a2)
castTypeFilter TypeFilter fk a
filtr
                    Maybe (TypeFilter fk a) -> TypeFilter fk a -> TypeFilter fk a
forall a. Maybe a -> a -> a
?: Text -> TypeFilter fk a
forall a. HasCallStack => Text -> a
error Text
"Something is wrong, failed to cast filter!"
          MatchPredicate backend -> Maybe (MatchPredicate backend)
forall (m :: * -> *) a. Monad m => a -> m a
return (MatchPredicate backend -> Maybe (MatchPredicate backend))
-> MatchPredicate backend -> Maybe (MatchPredicate backend)
forall a b. (a -> b) -> a -> b
$ FilteringApp backend ('TyNamedParam name (fk a))
-> TypeFilter fk a -> MatchPredicate backend
forall k (backend :: k) (fk :: * -> FilterKind *) a
       (name :: Symbol).
BackendApplyTypeFilter backend fk a =>
FilteringApp backend ('TyNamedParam name (fk a))
-> TypeFilter fk a -> MatchPredicate backend
backendApplyTypeFilter FilteringApp backend a
FilteringApp backend ('TyNamedParam name (fk a))
app TypeFilter fk a
filtr'

        , FilteringSpecApp backend params
-> SomeFilter params -> Maybe (MatchPredicate backend)
forall k (backend :: k) (params :: [TyNamedFilter]).
BackendApplySomeFilter backend params =>
FilteringSpecApp backend params
-> SomeFilter params -> Maybe (MatchPredicate backend)
backendApplySomeFilter' @backend @params FilteringSpecApp backend params
HList (FilteringApp backend) as
fields (Text -> TypeFilter fk a -> SomeFilter params
forall (fk :: * -> FilterKind *) a (params :: [TyNamedFilter]).
(Typeable fk, Typeable a) =>
Text -> TypeFilter fk a -> SomeFilter params
SomeFilter Text
name TypeFilter fk a
filtr)
        ]

-- | Applies a filter to a set of response fields which matter for filtering.
backendApplySomeFilter
    :: BackendApplySomeFilter backend params
    => FilteringSpecApp backend params
    -> SomeFilter params
    -> MatchPredicate backend
backendApplySomeFilter :: FilteringSpecApp backend params
-> SomeFilter params -> MatchPredicate backend
backendApplySomeFilter FilteringSpecApp backend params
app SomeFilter params
filtr =
    FilteringSpecApp backend params
-> SomeFilter params -> Maybe (MatchPredicate backend)
forall k (backend :: k) (params :: [TyNamedFilter]).
BackendApplySomeFilter backend params =>
FilteringSpecApp backend params
-> SomeFilter params -> Maybe (MatchPredicate backend)
backendApplySomeFilter' FilteringSpecApp backend params
app SomeFilter params
filtr Maybe (MatchPredicate backend)
-> MatchPredicate backend -> MatchPredicate backend
forall a. Maybe a -> a -> a
?: Text -> MatchPredicate backend
forall a. HasCallStack => Text -> a
error Text
"SomeFilter invariants violated"
    -- TODO: actually we're not protected from this error as soon as SomeFilter can be
    -- unwrapped and wrapped back

-- | Applies multiple filters to a set of response fields which matter for filtering.
backendApplyFilters
    :: forall backend params.
       BackendApplySomeFilter backend params
    => FilteringSpec params
    -> FilteringSpecApp backend params
    -> [MatchPredicate backend]
backendApplyFilters :: FilteringSpec params
-> FilteringSpecApp backend params -> [MatchPredicate backend]
backendApplyFilters (FilteringSpec [SomeFilter params]
filters) FilteringSpecApp backend params
app =
    (SomeFilter params -> MatchPredicate backend)
-> [SomeFilter params] -> [MatchPredicate backend]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (FilteringSpecApp backend params
-> SomeFilter params -> MatchPredicate backend
forall k (backend :: k) (params :: [TyNamedFilter]).
BackendApplySomeFilter backend params =>
FilteringSpecApp backend params
-> SomeFilter params -> MatchPredicate backend
backendApplySomeFilter FilteringSpecApp backend params
app) [SomeFilter params]
filters

-------------------------------------------------------------------------
-- Building filters
-------------------------------------------------------------------------

-- | Implement an automatic filter.
-- User-provided filtering operation will do filter on this value.
filterOn
    :: forall name backend a.
       (Typeable a)
    => AutoFilteredValue backend a
    -> FilteringApp backend ('TyNamedParam name ('AutoFilter a))
filterOn :: AutoFilteredValue backend a
-> FilteringApp backend ('TyNamedParam name ('AutoFilter a))
filterOn = AutoFilteredValue backend a
-> FilteringApp backend ('TyNamedParam name ('AutoFilter a))
forall k a (backend :: k) (a :: Symbol).
Typeable a =>
AutoFilteredValue backend a
-> FilteringApp backend ('TyNamedParam a ('AutoFilter a))
AutoFilteringApp

-- | Implement a manual filter.
-- You are provided with a value which user supplied and so you have
-- to construct a Beam predicate involving that value and relevant response fields.
manualFilter
    :: forall name backend a.
       (Typeable a)
    => (a -> MatchPredicate backend)
    -> FilteringApp backend ('TyNamedParam name ('ManualFilter a))
manualFilter :: (a -> MatchPredicate backend)
-> FilteringApp backend ('TyNamedParam name ('ManualFilter a))
manualFilter = (a -> MatchPredicate backend)
-> FilteringApp backend ('TyNamedParam name ('ManualFilter a))
forall k a (backend :: k) (name :: Symbol).
Typeable a =>
(a -> MatchPredicate backend)
-> FilteringApp backend ('TyNamedParam name ('ManualFilter a))
ManualFilteringApp