{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Servant.Record (RecordParam, UnRecordParam) where
import Servant.API
import Data.Proxy
import GHC.TypeLits
import GHC.Generics

-- | RecordParam uses the fields in the record to represent the
-- parameters.  The name of the field is used as parameter name, and
-- the type is the return type.  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 records:
--
-- @
-- data UserParams = UserParams
--   { category :: Maybe Category
--   , sort_by :: Sortby
--   , with_schema :: Bool
--   , filters :: [Filter]
--   }
--
-- type API = "users" :> RecordParam UserParams :> Get '[JSON] User
-- @

data RecordParam (a :: *)

type family ServantAppend x y where
  ServantAppend (a :> b) c = a :> ServantAppend b c
  ServantAppend a c = a :> c

-- | Type family to rewrite a RecordParam Api to a regular servant API.
-- Useful to define instances for classes that extract information from
-- the API type, such as Servant.Swagger, or servant-foreign.
--
-- Typical use:
-- 
-- > instance SomeClass (UnRecordParam (RecordParam a :> api))) =>
-- >          SomeClass (RecordParam a :> api) where
-- >    someMethod _ =
-- >      someMethod (Proxy :: Proxy (UnRecordParam (RecordParam a :> api))

type family UnRecordParam (x :: *) :: * where
  UnRecordParam (a :> b) = ServantAppend (UnRecordParam a) b
  UnRecordParam (RecordParam a) = UnRecordParam (Rep a ())
  UnRecordParam (D1 m c d) = UnRecordParam (c d)
  UnRecordParam ((a :*: b) d) = ServantAppend (UnRecordParam (a d))
                                (UnRecordParam (b d))
  UnRecordParam (C1 m a d) = UnRecordParam (a d)
  UnRecordParam (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 Bool) d) =
    QueryFlag sym
  UnRecordParam (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 [a]) d) =
    QueryParams sym a
  UnRecordParam (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 (Maybe a)) d) =
    QueryParam' [Optional, Strict] sym a
  UnRecordParam (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 a) d) =
    QueryParam' [Required, Strict] sym a
  
instance (Generic a, GHasLink (Rep a) sub) => HasLink (RecordParam a :> sub)
  where
    type MkLink (RecordParam a :> sub) b = a -> MkLink sub b
    toLink :: (Link -> a)
-> Proxy (RecordParam a :> sub)
-> Link
-> MkLink (RecordParam a :> sub) a
toLink Link -> a
toA Proxy (RecordParam a :> sub)
_ Link
l a
record =
      (Link -> a) -> Proxy sub -> Link -> Rep a () -> MkLink sub a
forall (a :: * -> *) sub b.
GHasLink a sub =>
(Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b
gToLink Link -> a
toA (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub) Link
l (a -> Rep a ()
forall a x. Generic a => a -> Rep a x
from a
record :: Rep a ())

data GParam a

instance GHasLink a sub => HasLink (GParam (a ()) :> sub) where
  type MkLink (GParam (a ()) :> sub) b = a () -> MkLink sub b
  toLink :: (Link -> a)
-> Proxy (GParam (a ()) :> sub)
-> Link
-> MkLink (GParam (a ()) :> sub) a
toLink Link -> a
toA Proxy (GParam (a ()) :> sub)
_ = (Link -> a) -> Proxy sub -> Link -> a () -> MkLink sub a
forall (a :: * -> *) sub b.
GHasLink a sub =>
(Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b
gToLink Link -> a
toA (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub)
  {-# INLINE toLink #-}
  
class HasLink sub => GHasLink (a :: * -> *) sub where
  gToLink :: (Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b

instance GHasLink c sub => GHasLink (D1 m c) sub where
  gToLink :: (Link -> b) -> Proxy sub -> Link -> D1 m c () -> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (M1 c ()
x) = (Link -> b) -> Proxy sub -> Link -> c () -> MkLink sub b
forall (a :: * -> *) sub b.
GHasLink a sub =>
(Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b
gToLink Link -> b
toA (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub) Link
l c ()
x
  {-# INLINE gToLink #-}

instance ( HasLink sub
         , GHasLink a (GParam (b ()) :> sub)
         )
         => GHasLink (a :*: b) sub where
  gToLink :: (Link -> b) -> Proxy sub -> Link -> (:*:) a b () -> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (a ()
a :*: b ()
b) =
    (Link -> b)
-> Proxy (GParam (b ()) :> sub)
-> Link
-> a ()
-> b ()
-> MkLink sub b
forall (a :: * -> *) sub b.
GHasLink a sub =>
(Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b
gToLink Link -> b
toA (Proxy (GParam (b ()) :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (GParam (b ()) :> sub)) Link
l a ()
a b ()
b
  {-# INLINE gToLink #-}

instance (GHasLink a sub, HasLink sub) =>
         GHasLink (C1 m a) sub where
  gToLink :: (Link -> b) -> Proxy sub -> Link -> C1 m a () -> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (M1 a ()
x) = (Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b
forall (a :: * -> *) sub b.
GHasLink a sub =>
(Link -> b) -> Proxy sub -> Link -> a () -> MkLink sub b
gToLink Link -> b
toA (Proxy sub
forall k (t :: k). Proxy t
Proxy :: Proxy sub) Link
l a ()
x
  {-# INLINE gToLink #-}

instance {-# OVERLAPPING #-}
  ( KnownSymbol sym
  , HasLink sub
  ) =>
  GHasLink (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 Bool)) sub where
  gToLink :: (Link -> b)
-> Proxy sub
-> Link
-> S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 Bool) ()
-> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (M1 (K1 Bool
x)) =
    (Link -> b)
-> Proxy (QueryFlag sym :> sub) -> Link -> Bool -> MkLink sub b
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> b
toA (Proxy (QueryFlag sym :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryFlag sym :> sub)) Link
l Bool
x
  {-# INLINE gToLink #-}

instance {-# OVERLAPPING #-}
  ( KnownSymbol sym
  , ToHttpApiData a
  , HasLink (a :> sub)
  , HasLink sub) =>
  GHasLink (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 [a])) sub where
  gToLink :: (Link -> b)
-> Proxy sub
-> Link
-> S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 [a]) ()
-> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (M1 (K1 [a]
x)) =
    (Link -> b)
-> Proxy (QueryParams sym a :> sub) -> Link -> [a] -> MkLink sub b
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> b
toA (Proxy (QueryParams sym a :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryParams sym a :> sub)) Link
l [a]
x
  {-# INLINE gToLink #-}

instance {-# OVERLAPPING #-}
  ( KnownSymbol sym
  , ToHttpApiData a
  , HasLink (a :> sub)
  , HasLink sub) =>
  GHasLink (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 (Maybe a))) sub where
  gToLink :: (Link -> b)
-> Proxy sub
-> Link
-> S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 (Maybe a)) ()
-> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (M1 (K1 Maybe a
x)) =
    (Link -> b)
-> Proxy (QueryParam' '[Optional, Strict] sym a :> sub)
-> Link
-> Maybe a
-> MkLink sub b
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> b
toA (Proxy (QueryParam' '[Optional, Strict] sym a :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryParam' '[Optional, Strict] sym a :> sub))
    Link
l Maybe a
x
  {-# INLINE gToLink #-}

instance {-# OVERLAPPABLE #-}
  ( KnownSymbol sym
  , ToHttpApiData a
  , HasLink (a :> sub)
  , HasLink sub) =>
  GHasLink (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 a)) sub where
  gToLink :: (Link -> b)
-> Proxy sub
-> Link
-> S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 a) ()
-> MkLink sub b
gToLink Link -> b
toA Proxy sub
_ Link
l (M1 (K1 a
x)) =
    (Link -> b)
-> Proxy (QueryParam' '[Required, Strict] sym a :> sub)
-> Link
-> a
-> MkLink sub b
forall k (endpoint :: k) a.
HasLink endpoint =>
(Link -> a) -> Proxy endpoint -> Link -> MkLink endpoint a
toLink Link -> b
toA (Proxy (QueryParam' '[Required, Strict] sym a :> sub)
forall k (t :: k). Proxy t
Proxy :: Proxy (QueryParam' '[Required, Strict] sym a :> sub))
    Link
l a
x
  {-# INLINE gToLink #-}