{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Server.Record () where
import Servant.API
import Data.Proxy
import GHC.TypeLits
import GHC.Generics
import Servant.Server
import Servant.Server.Internal
import Servant.Record
class GHasServer (a :: * -> *) context api where
gRoute :: Proxy api -> Context context -> Delayed env (a () -> Server api)
-> Router env
gHoistServerWithContext :: Proxy api -> Proxy context
-> (forall x. m x -> n x)
-> (a () -> ServerT api m)
-> (a () -> ServerT api n)
data GParam a
instance ( Generic a
, GHasServer (Rep a) context api
) =>
HasServer (RecordParam a :> api) context where
type ServerT (RecordParam a :> api) m = a -> ServerT api m
route _ context env = gRoute (Proxy :: Proxy api) context $
(\f (x :: Rep a ()) -> f (to x)) <$> env
{-# INLINE route #-}
hoistServerWithContext _ pc nt s x =
gHoistServerWithContext (Proxy :: Proxy api) pc nt (s . to)
(from x :: Rep a ())
{-# INLINE hoistServerWithContext #-}
instance GHasServer a context api =>
HasServer (GParam (a ()) :> api) context where
type ServerT (GParam (a ()) :> api) m = a () -> ServerT api m
route _ = gRoute (Proxy :: Proxy api)
{-# INLINE route #-}
hoistServerWithContext _ = gHoistServerWithContext (Proxy :: Proxy api)
{-# INLINE hoistServerWithContext #-}
instance GHasServer c context api =>
GHasServer (D1 m3 c) context api where
gRoute _ context env = gRoute (Proxy :: Proxy api) context $
(\f x -> f (M1 x)) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (M1 x) =
gHoistServerWithContext (Proxy :: Proxy api) pc nt (s . M1) x
{-# INLINE gHoistServerWithContext #-}
instance GHasServer a context (GParam (b ()) :> api) =>
GHasServer ((a :*: b)) context api where
gRoute _ context env = gRoute (Proxy :: Proxy (GParam (b ()) :> api))
context $ (\f x y -> f (x :*: y)) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (x :*: y) =
gHoistServerWithContext (Proxy :: Proxy (GParam (b ()) :> api))
pc nt (\x' y' -> s (x' :*: y')) x y
{-# INLINE gHoistServerWithContext #-}
instance GHasServer a context api =>
GHasServer (C1 n a) context api where
gRoute _ context env = gRoute (Proxy :: Proxy api) context $
(\f x -> f (M1 x)) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (M1 x) =
gHoistServerWithContext (Proxy :: Proxy api) pc nt (s . M1) x
{-# INLINE gHoistServerWithContext #-}
instance {-# OVERLAPPING #-}
( HasServer api context
, KnownSymbol sym
) =>
GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 Bool))
context
api where
gRoute _ context env = route (Proxy :: Proxy (QueryFlag sym :> api))
context $ (\f x -> f (M1 (K1 x))) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (M1 (K1 x)) =
hoistServerWithContext (Proxy :: Proxy (QueryFlag sym :> api)) pc nt
(s . M1 . K1) x
{-# INLINE gHoistServerWithContext #-}
instance {-# OVERLAPPING #-}
( HasServer api context
, FromHttpApiData a
, KnownSymbol sym
) =>
GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 [a]))
context
api where
gRoute _ context env = route (Proxy :: Proxy (QueryParams sym a :> api))
context $ (\f x -> f (M1 (K1 x))) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (M1 (K1 x)) =
hoistServerWithContext (Proxy :: Proxy (QueryParams sym a :> api)) pc nt
(s . M1 . K1) x
{-# INLINE gHoistServerWithContext #-}
instance {-# OVERLAPPING #-}
( HasServer api context
, FromHttpApiData a
, KnownSymbol sym
) =>
GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 (Maybe a)))
context
api where
gRoute _ context env =
route (Proxy :: Proxy (QueryParam sym a :> api))
context $ (\f x -> f (M1 (K1 x))) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (M1 (K1 x)) =
hoistServerWithContext (Proxy :: Proxy (QueryParam sym a :> api))
pc nt (s . M1 . K1) x
{-# INLINE gHoistServerWithContext #-}
instance {-# OVERLAPPABLE #-}
( HasServer api context
, FromHttpApiData a
, KnownSymbol sym
) =>
GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 a))
context
api where
gRoute _ context env =
route (Proxy :: Proxy (QueryParam' '[Required, Strict] sym a :> api))
context $ (\f x -> f (M1 (K1 x))) <$> env
{-# INLINE gRoute #-}
gHoistServerWithContext _ pc nt s (M1 (K1 x)) =
hoistServerWithContext
(Proxy :: Proxy (QueryParam' '[Required, Strict] sym a :> api))
pc nt (s . M1 . K1) x
{-# INLINE gHoistServerWithContext #-}