{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE EmptyDataDecls #-}

{-|
This module uses the named package to match names with parameters. For example, this api:

@
type API = "users" :> (QueryParam "category" Category :>
                       QueryParam' '[Required, Strict] "sort_by" SortBy :>
                       QueryFlag "with_schema" :>
                       QueryParams "filters" Filter :>
                       Get '[JSON] User
@

can be written with named:

@
type API = "users" :> (OptionalQueryParam "category" Category :>
                       NamedQueryParam "sort_by" SortBy :>
                       NamedQueryFlag "with_schema" :>
                       NamedQueryParams "filters" Filter :>
                       Get '[JSON] User
@

The servant-named-client and servant-named-server will create
functions that use the `named` package to match the names with the
parameters.
-}
module Servant.Named (NamedQueryParam, OptionalQueryParam, NamedQueryParams,
                      NamedQueryFlag, NamedQueryParam') where
import Servant.API
import Servant.API.Modifiers
import Data.Proxy
import GHC.TypeLits
import Data.Functor.Identity
import Data.Maybe
import Named

-- | Like `QueryParam'`, but instead of extracting a type @a@, it
-- extracts a named type @`NamedF` f a sym@, where the name
-- corresponds to the query parameter string.
data NamedQueryParam' (mods :: [*]) (sym :: Symbol) (a :: *)

unarg :: NamedF f a name -> f a
unarg :: NamedF f a name -> f a
unarg (ArgF f a
a) = f a
a

-- | type family to rewrite a named queryparam to a regular
-- queryparam.  Useful to define instances for classes that extract
-- information from the API type., for example servant-foreign, or
-- servant-swagger.
type family UnNameParam x where
  UnNameParam (NamedQueryParams sym a) = QueryParams sym a
  UnNameParam (NamedQueryParam' mods sym a) = QueryParam' mods sym a
  UnNameParam (NamedQueryFlag sym) = QueryFlag sym

instance (KnownSymbol sym, ToHttpApiData v, HasLink sub,
          SBoolI (FoldRequired mods))
    => HasLink (NamedQueryParam' mods sym v :> sub)
  where
    type MkLink (NamedQueryParam' mods sym v :> sub) a =
      If (FoldRequired mods) (sym :! v) (sym :? v) -> MkLink sub a
    toLink :: (Link -> a)
-> Proxy (NamedQueryParam' mods sym v :> sub)
-> Link
-> MkLink (NamedQueryParam' mods sym v :> sub) a
toLink Link -> a
toA Proxy (NamedQueryParam' mods sym v :> sub)
_ Link
l If (FoldRequired mods) (sym :! v) (sym :? v)
qparam =
      (Link -> a)
-> Proxy (QueryParam' mods sym v :> sub)
-> Link
-> MkLink (QueryParam' mods sym v :> sub) a
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (Proxy (QueryParam' mods sym v :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryParam' mods sym v :> sub)) Link
l (If (FoldRequired mods) v (Maybe v) -> MkLink sub a)
-> If (FoldRequired mods) v (Maybe v) -> MkLink sub a
forall a b. (a -> b) -> a -> b
$
      case SBool (FoldRequired mods)
forall (b :: Bool). SBoolI b => SBool b
sbool :: SBool (FoldRequired mods) of
        SBool (FoldRequired mods)
STrue  -> Identity v -> v
forall a. Identity a -> a
runIdentity ((sym :! v) -> Identity v
forall (f :: * -> *) a (name :: Symbol). NamedF f a name -> f a
unarg If (FoldRequired mods) (sym :! v) (sym :? v)
sym :! v
qparam)
        SBool (FoldRequired mods)
SFalse -> (sym :? v) -> Maybe v
forall (f :: * -> *) a (name :: Symbol). NamedF f a name -> f a
unarg If (FoldRequired mods) (sym :! v) (sym :? v)
sym :? v
qparam

-- | Lookup the value associated to the sym query string parameter and
-- try to extract it as an optional named argument of type @sym `:?`
-- a@.
type OptionalQueryParam = NamedQueryParam' [Optional, Strict]

-- | Like `QueryParam`, but instead of extracting a type @a@, it
-- extracts a named type @named `:!` a@, where named corresponds to
-- the query parameter string.
type NamedQueryParam = NamedQueryParam' [Required, Strict]

-- | Like `QueryParams`, but extracts a named type @named `:?` [a]@
-- instead, where named corresponds to the query parameter string.
-- The default value is the empty list `[]`
data NamedQueryParams (sym :: Symbol) (a :: *)

instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
         => HasLink (NamedQueryParams sym v :> sub)
  where
    type MkLink (NamedQueryParams sym v :> sub) a = sym :? [v] -> MkLink sub a
    toLink :: (Link -> a)
-> Proxy (NamedQueryParams sym v :> sub)
-> Link
-> MkLink (NamedQueryParams sym v :> sub) a
toLink Link -> a
toA Proxy (NamedQueryParams sym v :> sub)
_ Link
l (ArgF Maybe [v]
params) =
      (Link -> a)
-> Proxy (QueryParams sym v :> sub)
-> Link
-> MkLink (QueryParams sym v :> sub) a
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (Proxy (QueryParams sym v :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryParams sym v :> sub)) Link
l ([v] -> MkLink sub a) -> [v] -> MkLink sub a
forall a b. (a -> b) -> a -> b
$
      [v] -> Maybe [v] -> [v]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [v]
params

-- | Like `QueryFlag, but extracts a named type @named `:?` Bool@
-- instead, where named corresponds to the query parameter string.
-- The default value is False.
data NamedQueryFlag (sym :: Symbol)
instance (KnownSymbol sym, HasLink sub)
    => HasLink (NamedQueryFlag sym :> sub)
  where
    type MkLink (NamedQueryFlag sym :> sub) a =
      (sym :? Bool) -> MkLink sub a
    toLink :: (Link -> a)
-> Proxy (NamedQueryFlag sym :> sub)
-> Link
-> MkLink (NamedQueryFlag sym :> sub) a
toLink Link -> a
toA Proxy (NamedQueryFlag sym :> sub)
_ Link
l (ArgF Maybe Bool
qparam) =
      (Link -> a)
-> Proxy (QueryFlag sym :> sub)
-> Link
-> MkLink (QueryFlag sym :> sub) a
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> a
toA (Proxy (QueryFlag sym :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryFlag sym :> sub)) Link
l (Bool -> MkLink sub a) -> Bool -> MkLink sub a
forall a b. (a -> b) -> a -> b
$
      Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
qparam