100 lines
3.9 KiB
Haskell
100 lines
3.9 KiB
Haskell
|
{-# LANGUAGE CPP #-}
|
||
|
|
{-# LANGUAGE DataKinds #-}
|
||
|
|
{-# LANGUAGE FlexibleContexts #-}
|
||
|
|
{-# LANGUAGE FlexibleInstances #-}
|
||
|
|
{-# LANGUAGE GADTs #-}
|
||
|
|
{-# LANGUAGE KindSignatures #-}
|
||
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||
|
|
{-# LANGUAGE TypeOperators #-}
|
||
|
|
|
||
|
|
#include "overlapping-compat.h"
|
||
|
|
|
||
|
|
module Servant.Server.Internal.Context where
|
||
|
|
|
||
|
|
import Data.Proxy
|
||
|
|
import GHC.TypeLits
|
||
|
|
|
||
|
|
-- | When calling 'Servant.Server.serve' you have to supply a context
|
||
|
|
-- value of type @'Context' contextTypes@. This parameter is used to pass values
|
||
|
|
-- to combinators. (It shouldn't be confused with general configuration
|
||
|
|
-- parameters for your web app, like the port, etc.). If you don't use
|
||
|
|
-- combinators that require any context entries, you can just use `serve` (or
|
||
|
|
-- pass 'EmptyContext'). To create a context with entries, use the operator
|
||
|
|
-- @(':.')@. The parameter of the type 'Context' is a type-level list reflecting
|
||
|
|
-- the types of the contained context entries:
|
||
|
|
--
|
||
|
|
-- >>> :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 EmptyContext = "EmptyContext"
|
||
|
|
instance (Show a, Show (Context as)) => Show (Context (a ': as)) where
|
||
|
|
showsPrec outerPrecedence (a :. as) =
|
||
|
|
showParen (outerPrecedence > 5) $
|
||
|
|
shows a . showString " :. " . shows as
|
||
|
|
|
||
|
|
instance Eq (Context '[]) where
|
||
|
|
_ == _ = True
|
||
|
|
instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
|
||
|
|
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
|
||
|
|
|
||
|
|
-- | 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 (_ :. xs) = getContextEntry xs
|
||
|
|
|
||
|
|
instance OVERLAPPING_
|
||
|
|
HasContextEntry (val ': xs) val where
|
||
|
|
getContextEntry (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 Proxy context =
|
||
|
|
let NamedContext subContext = getContextEntry context :: NamedContext name subContext
|
||
|
|
in subContext
|