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

module Servant.Server.Internal.Context where

import           Data.Proxy
import           GHC.TypeLits

-- | '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 type-level lists.
--
-- Hint: import it as
--
-- > import Servant.Server (type (.++))
type family (.++) (l1 :: [*]) (l2 :: [*]) where
  '[] .++ a = a
  (a ': as) .++ b = a ': (as .++ b)

-- | Append two contexts.
(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)
Context l1
EmptyContext .++ :: forall (l1 :: [*]) (l2 :: [*]).
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 :: [*]). x -> Context xs -> Context (x : xs)
:. (Context xs
as Context xs -> Context l2 -> Context (xs .++ l2)
forall (l1 :: [*]) (l2 :: [*]).
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 :: [*]) (val :: *) 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 :: [*]) 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.
data NamedContext (name :: Symbol) (subContext :: [*])
  = 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 :: [*]) (name :: Symbol) (subContext :: [*]).
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 :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context context
context :: NamedContext name subContext
  in Context subContext
subContext