{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | These are custom combinators for Servant.Server.UsingContextSpec.
--
-- (For writing your own combinators you need to import Internal modules, for
-- just *using* combinators that require a Context, you don't. This module is
-- separate from Servant.Server.UsingContextSpec to test that the module imports
-- work out this way.)
module Servant.Server.UsingContextSpec.TestCombinators where

import Data.Kind (Type)
import GHC.TypeLits

import Servant

data ExtractFromContext

instance
  (HasContextEntry context String, HasServer subApi context)
  => HasServer (ExtractFromContext :> subApi) context
  where
  type
    ServerT (ExtractFromContext :> subApi) m =
      String -> ServerT subApi m

  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy subApi) pc nt . s

  route Proxy context delayed =
    route subProxy context (fmap injectContext delayed)
    where
      subProxy :: Proxy subApi
      subProxy = Proxy

      injectContext f = f (getContextEntry context)

data InjectIntoContext

instance
  HasServer subApi (String ': context)
  => HasServer (InjectIntoContext :> subApi) context
  where
  type
    ServerT (InjectIntoContext :> subApi) m =
      ServerT subApi m

  hoistServerWithContext _ _ = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy (String ': context))

  route Proxy context = route subProxy newContext
    where
      subProxy :: Proxy subApi
      subProxy = Proxy

      newContext = ("injected" :: String) :. context

data NamedContextWithBirdface (name :: Symbol) (subContext :: [Type])

instance
  (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)
  => HasServer (NamedContextWithBirdface name subContext :> subApi) context
  where
  type
    ServerT (NamedContextWithBirdface name subContext :> subApi) m =
      ServerT subApi m

  hoistServerWithContext _ _ = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext)

  route Proxy context = route subProxy subContext
    where
      subProxy :: Proxy subApi
      subProxy = Proxy

      subContext :: Context subContext
      subContext = descendIntoNamedContext (Proxy :: Proxy name) context
