{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveAnyClass #-}

module Servant.Hateoas.Layer.Type
(
  -- * Type
  Layer(..),

  -- ** Getter
  LayerApiCs, RelativeChildren, LayerVerb,

  -- * API-construction
  LayerApi, MkPrefix, type (++),

  -- * Intermediate
  Intermediate(..), GetIntermediate
)
where

import Servant
import Servant.Server.Internal.Router
import Servant.Hateoas.Internal.Sym
import Servant.Hateoas.Resource
import Data.Aeson
import Data.Kind

-- | Convenience alias for 'AppendList'.
type (++) xs ys = AppendList xs ys

-- | Data-kind for a layer in an API.
--
-- ==== __Example__
--
-- @
-- ''Layer' '['Sym' \"api\", 'Sym' \"user\"] '['Capture' \"id\" 'Int', 'Sym' \"vip\"] 'GetIntermediate'
-- @
--
-- Represents the API
--
-- @
-- \"api\" :> \"user\" :> 'GetIntermediate'
-- @ with children
--
-- @
-- \"api\" :> \"user\" :> 'Capture' \"id\" 'Int' :> 'GetIntermediate'
-- @ and
--
-- @
-- \"api\" :> \"user\" :> \"vip\" :> 'GetIntermediate'
-- @
data Layer = Layer
  { Layer -> [*]
api              :: [Type]      -- ^ The API of this layer represented as list. Folding it with ':>' results in the actual API, see 'MkPrefix'.
  , Layer -> [*]
relativeChildren :: [Type]      -- ^ All immediate children of this layer.
  , Layer -> *
verb             :: Type        -- ^ The 'Verb' for this layer.
  }

-- | Type-level getter for the API of a 'Layer'.
type family LayerApiCs (a :: Layer) where
  LayerApiCs ('Layer api _ _) = api

-- | Type-level getter for the children of a 'Layer'.
type family RelativeChildren (a :: Layer) where
  RelativeChildren ('Layer _ children _) = children

-- | Type-level getter for the verb of a 'Layer'.
type family LayerVerb (a :: Layer) where
  LayerVerb ('Layer _ _ verb) = verb

-- | Constructs the actual API of a 'Layer'.
type family LayerApi (a :: Layer) where
  LayerApi ('Layer api _ verb) = MkPrefix api verb

-- | Folds a list of path segments into an API by intercalating '(:>)'.
--
-- ==== __Example__
--
-- @
-- 'MkPrefix' '['Sym' \"api\", 'Sym' \"user\"] 'GetIntermediate'
-- @ resolves to
--
-- @
-- 'Sym' \"api\" :> 'Sym' \"user\" :> 'GetIntermediate'
-- @
type MkPrefix :: [Type] -> Type -> Type
type family MkPrefix prefix api where
  MkPrefix (Sym x      ': xs) api = x :> MkPrefix xs api
  MkPrefix (x          ': xs) api = x :> MkPrefix xs api
  MkPrefix '[]                api = api

instance HasServer (MkPrefix apiCs verb) context => HasServer ('Layer apiCs cs verb) context where
  type ServerT ('Layer apiCs cs verb) m = ServerT (MkPrefix apiCs verb) m
  route :: forall env.
Proxy ('Layer apiCs cs verb)
-> Context context
-> Delayed env (Server ('Layer apiCs cs verb))
-> Router env
route Proxy ('Layer apiCs cs verb)
_ = Proxy (MkPrefix apiCs verb)
-> Context context
-> Delayed env (Server (MkPrefix apiCs verb))
-> Router' env RoutingApplication
forall env.
Proxy (MkPrefix apiCs verb)
-> Context context
-> Delayed env (Server (MkPrefix apiCs verb))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(MkPrefix apiCs verb))
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy ('Layer apiCs cs verb)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ('Layer apiCs cs verb) m
-> ServerT ('Layer apiCs cs verb) n
hoistServerWithContext Proxy ('Layer apiCs cs verb)
_ = Proxy (MkPrefix apiCs verb)
-> Proxy context
-> (forall {x}. m x -> n x)
-> ServerT (MkPrefix apiCs verb) m
-> ServerT (MkPrefix apiCs verb) n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy (MkPrefix apiCs verb)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (MkPrefix apiCs verb) m
-> ServerT (MkPrefix apiCs verb) n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(MkPrefix apiCs verb))

instance HasServer ('[] :: [Layer]) context where
  type ServerT '[] m = ServerT EmptyAPI m
  route :: forall env.
Proxy '[]
-> Context context -> Delayed env (Server '[]) -> Router env
route Proxy '[]
_ = Proxy EmptyAPI
-> Context context
-> Delayed env (Server EmptyAPI)
-> Router' env RoutingApplication
forall env.
Proxy EmptyAPI
-> Context context -> Delayed env (Server EmptyAPI) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @EmptyAPI)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy '[]
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT '[] m
-> ServerT '[] n
hoistServerWithContext Proxy '[]
_ = Proxy EmptyAPI
-> Proxy context
-> (forall {x}. m x -> n x)
-> ServerT EmptyAPI m
-> ServerT EmptyAPI n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy EmptyAPI
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT EmptyAPI m
-> ServerT EmptyAPI n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @EmptyAPI)

instance (HasServer l context, HasServer ls context) => HasServer (l ': ls :: [Layer]) context where
  type ServerT (l ': ls) m = ServerT l m :<|> ServerT ls m
  route :: forall env.
Proxy (l : ls)
-> Context context -> Delayed env (Server (l : ls)) -> Router env
route Proxy (l : ls)
_ Context context
ctx Delayed env (Server (l : ls))
delayed = Proxy l -> Context context -> Delayed env (Server l) -> Router env
forall env.
Proxy l -> Context context -> Delayed env (Server l) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
forall (t :: Layer). Proxy t
Proxy @l) Context context
ctx ((\(Server l
sl :<|> ServerT ls Handler
_) -> Server l
sl) ((Server l :<|> ServerT ls Handler) -> Server l)
-> Delayed env (Server l :<|> ServerT ls Handler)
-> Delayed env (Server l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (Server l :<|> ServerT ls Handler)
Delayed env (Server (l : ls))
delayed) Router env -> Router env -> Router env
forall env a. Router' env a -> Router' env a -> Router' env a
`choice` Proxy ls
-> Context context
-> Delayed env (ServerT ls Handler)
-> Router env
forall env.
Proxy ls
-> Context context
-> Delayed env (ServerT ls Handler)
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall (t :: [Layer]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ls) Context context
ctx ((\(Server l
_ :<|> ServerT ls Handler
sls) -> ServerT ls Handler
sls) ((Server l :<|> ServerT ls Handler) -> ServerT ls Handler)
-> Delayed env (Server l :<|> ServerT ls Handler)
-> Delayed env (ServerT ls Handler)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delayed env (Server l :<|> ServerT ls Handler)
Delayed env (Server (l : ls))
delayed)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (l : ls)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (l : ls) m
-> ServerT (l : ls) n
hoistServerWithContext Proxy (l : ls)
_ Proxy context
ctx forall x. m x -> n x
f (ServerT l m
sl :<|> ServerT ls m
sls) = Proxy l
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT l m
-> ServerT l n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy l
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT l m
-> ServerT l n
hoistServerWithContext (forall {k} (t :: k). Proxy t
forall (t :: Layer). Proxy t
Proxy @l) Proxy context
ctx m x -> n x
forall x. m x -> n x
f ServerT l m
sl ServerT l n -> ServerT ls n -> ServerT l n :<|> ServerT ls n
forall a b. a -> b -> a :<|> b
:<|> Proxy ls
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ls m
-> ServerT ls n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy ls
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT ls m
-> ServerT ls n
hoistServerWithContext (forall (t :: [Layer]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ls) Proxy context
ctx m x -> n x
forall x. m x -> n x
f ServerT ls m
sls

-- | A response type for a 'Layer' that does not contain any data.
newtype Intermediate = Intermediate ()
  deriving newtype (Int -> Intermediate -> ShowS
[Intermediate] -> ShowS
Intermediate -> String
(Int -> Intermediate -> ShowS)
-> (Intermediate -> String)
-> ([Intermediate] -> ShowS)
-> Show Intermediate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Intermediate -> ShowS
showsPrec :: Int -> Intermediate -> ShowS
$cshow :: Intermediate -> String
show :: Intermediate -> String
$cshowList :: [Intermediate] -> ShowS
showList :: [Intermediate] -> ShowS
Show, Intermediate -> Intermediate -> Bool
(Intermediate -> Intermediate -> Bool)
-> (Intermediate -> Intermediate -> Bool) -> Eq Intermediate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Intermediate -> Intermediate -> Bool
== :: Intermediate -> Intermediate -> Bool
$c/= :: Intermediate -> Intermediate -> Bool
/= :: Intermediate -> Intermediate -> Bool
Eq, Eq Intermediate
Eq Intermediate =>
(Intermediate -> Intermediate -> Ordering)
-> (Intermediate -> Intermediate -> Bool)
-> (Intermediate -> Intermediate -> Bool)
-> (Intermediate -> Intermediate -> Bool)
-> (Intermediate -> Intermediate -> Bool)
-> (Intermediate -> Intermediate -> Intermediate)
-> (Intermediate -> Intermediate -> Intermediate)
-> Ord Intermediate
Intermediate -> Intermediate -> Bool
Intermediate -> Intermediate -> Ordering
Intermediate -> Intermediate -> Intermediate
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Intermediate -> Intermediate -> Ordering
compare :: Intermediate -> Intermediate -> Ordering
$c< :: Intermediate -> Intermediate -> Bool
< :: Intermediate -> Intermediate -> Bool
$c<= :: Intermediate -> Intermediate -> Bool
<= :: Intermediate -> Intermediate -> Bool
$c> :: Intermediate -> Intermediate -> Bool
> :: Intermediate -> Intermediate -> Bool
$c>= :: Intermediate -> Intermediate -> Bool
>= :: Intermediate -> Intermediate -> Bool
$cmax :: Intermediate -> Intermediate -> Intermediate
max :: Intermediate -> Intermediate -> Intermediate
$cmin :: Intermediate -> Intermediate -> Intermediate
min :: Intermediate -> Intermediate -> Intermediate
Ord, [Intermediate] -> Value
[Intermediate] -> Encoding
Intermediate -> Bool
Intermediate -> Value
Intermediate -> Encoding
(Intermediate -> Value)
-> (Intermediate -> Encoding)
-> ([Intermediate] -> Value)
-> ([Intermediate] -> Encoding)
-> (Intermediate -> Bool)
-> ToJSON Intermediate
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Intermediate -> Value
toJSON :: Intermediate -> Value
$ctoEncoding :: Intermediate -> Encoding
toEncoding :: Intermediate -> Encoding
$ctoJSONList :: [Intermediate] -> Value
toJSONList :: [Intermediate] -> Value
$ctoEncodingList :: [Intermediate] -> Encoding
toEncodingList :: [Intermediate] -> Encoding
$comitField :: Intermediate -> Bool
omitField :: Intermediate -> Bool
ToJSON)
  deriving anyclass (ToResource res)

type GetIntermediate = Get '[] Intermediate