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

    module Servant.Server.Internal.Context
      ( module Servant.Server.Internal.Context
      , module Servant.API.TypeLevel.List
      ) where

    import           Data.Kind
                     (Type)
    import           Data.Proxy
    import           GHC.TypeLits
    import           Servant.API.TypeLevel.List
                     (type (.++))

    -- | 'Context's are used to pass values to combinators. (They are __not__ meant
    -- to be used to pass parameters to your handlers, i.e. they should not replace
    -- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using
    -- with 'hoistServer'.) If you don't use combinators that
    -- require any context entries, you can just use 'Servant.Server.serve' as always.
    --
    -- If you are using combinators that require a non-empty 'Context' you have to
    -- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all
    -- the values your combinators need. A 'Context' is essentially a heterogeneous
    -- list and accessing the elements is being done by type (see 'getContextEntry').
    -- The parameter of the type 'Context' is a type-level list reflecting the types
    -- of the contained context entries. To create a 'Context' with entries, use the
    -- operator @(':.')@:
    --
    -- >>> :type True :. () :. EmptyContext
    -- True :. () :. EmptyContext :: Context '[Bool, ()]
    data Context contextTypes where
        EmptyContext :: Context '[]
        (:.) :: x -> Context xs -> Context (x ': xs)
    infixr 5 :.

    instance Show (Context '[]) where
      show :: Context '[] -> String
    show Context '[]
    EmptyContext = String
    "EmptyContext"
    instance (Show a, Show (Context as)) => Show (Context (a ': as)) where
      showsPrec :: Int -> Context (a : as) -> ShowS
    showsPrec Int
    outerPrecedence (x
    a :. Context xs
    as) =
        Bool -> ShowS -> ShowS
    showParen (Int
    outerPrecedence Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    5) (ShowS -> ShowS) -> ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $
          x -> ShowS
    forall a. Show a => a -> ShowS
    shows x
    a ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " :. " ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Context xs -> ShowS
    forall a. Show a => a -> ShowS
    shows Context xs
    as

    instance Eq (Context '[]) where
        Context '[]
    _ == :: Context '[] -> Context '[] -> Bool
    == Context '[]
    _ = Bool
    True
    instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
        x
    x1 :. Context xs
    y1 == :: Context (a : as) -> Context (a : as) -> Bool
    == x
    x2 :. Context xs
    y2 = x
    x1 x -> x -> Bool
    forall a. Eq a => a -> a -> Bool
    == x
    x
    x2 Bool -> Bool -> Bool
    && Context xs
    y1 Context xs -> Context xs -> Bool
    forall a. Eq a => a -> a -> Bool
    == Context xs
    Context xs
    y2

    -- | Append two contexts.
    (.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)
    Context l1
    EmptyContext .++ :: forall (l1 :: [Type]) (l2 :: [Type]).
    Context l1 -> Context l2 -> Context (l1 .++ l2)
    .++ Context l2
    a = Context l2
    Context (l1 .++ l2)
    a
    (x
    a :. Context xs
    as) .++ Context l2
    b = x
    a x -> Context (xs .++ l2) -> Context (x : (xs .++ l2))
    forall x (xs :: [Type]). x -> Context xs -> Context (x : xs)
    :. (Context xs
    as Context xs -> Context l2 -> Context (xs .++ l2)
    forall (l1 :: [Type]) (l2 :: [Type]).
    Context l1 -> Context l2 -> Context (l1 .++ l2)
    .++ Context l2
    b)

    -- | This class is used to access context entries in 'Context's. 'getContextEntry'
    -- returns the first value where the type matches:
    --
    -- >>> getContextEntry (True :. False :. EmptyContext) :: Bool
    -- True
    --
    -- If the 'Context' does not contain an entry of the requested type, you'll get
    -- an error:
    --
    -- >>> getContextEntry (True :. False :. EmptyContext) :: String
    -- ...
    -- ...No instance for ...HasContextEntry '[] [Char]...
    -- ...
    class HasContextEntry (context :: [Type]) (val :: Type) where
        getContextEntry :: Context context -> val

    instance {-# OVERLAPPABLE #-}
             HasContextEntry xs val => HasContextEntry (notIt ': xs) val where
        getContextEntry :: Context (notIt : xs) -> val
    getContextEntry (x
    _ :. Context xs
    xs) = Context xs -> val
    forall (context :: [Type]) val.
    HasContextEntry context val =>
    Context context -> val
    getContextEntry Context xs
    xs

    instance {-# OVERLAPPING #-}
             HasContextEntry (val ': xs) val where
        getContextEntry :: Context (val : xs) -> val
    getContextEntry (x
    x :. Context xs
    _) = val
    x
    x

    -- * support for named subcontexts

    -- | Normally context entries are accessed by their types. In case you need
    -- to have multiple values of the same type in your 'Context' and need to access
    -- them, we provide 'NamedContext'. You can think of it as sub-namespaces for
    -- 'Context's.
    newtype NamedContext (name :: Symbol) (subContext :: [Type])
      = NamedContext (Context subContext)

    -- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you
    -- won't have to use it yourself but instead use a combinator like
    -- 'Servant.API.WithNamedContext.WithNamedContext'.
    --
    -- This is how 'descendIntoNamedContext' works:
    --
    -- >>> :set -XFlexibleContexts
    -- >>> let subContext = True :. EmptyContext
    -- >>> :type subContext
    -- subContext :: Context '[Bool]
    -- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext
    -- >>> :type parentContext
    -- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]]
    -- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool]
    -- True :. EmptyContext
    descendIntoNamedContext :: forall context name subContext .
      HasContextEntry context (NamedContext name subContext) =>
      Proxy (name :: Symbol) -> Context context -> Context subContext
    descendIntoNamedContext :: forall (context :: [Type]) (name :: Symbol) (subContext :: [Type]).
    HasContextEntry context (NamedContext name subContext) =>
    Proxy name -> Context context -> Context subContext
    descendIntoNamedContext Proxy name
    Proxy Context context
    context =
      let NamedContext Context subContext
    subContext = Context context -> NamedContext name subContext
    forall (context :: [Type]) val.
    HasContextEntry context val =>
    Context context -> val
    getContextEntry Context context
    context :: NamedContext name subContext
      in Context subContext
    subContext