{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.Internal.Context where
import Data.Proxy
import GHC.TypeLits
data Context contextTypes where
EmptyContext :: Context '[]
(:.) :: x -> Context xs -> Context (x ': xs)
infixr 5 :.
instance Show (Context '[]) where
show :: Context '[] -> String
show EmptyContext = "EmptyContext"
instance (Show a, Show (Context as)) => Show (Context (a ': as)) where
showsPrec :: Int -> Context (a : as) -> ShowS
showsPrec outerPrecedence :: Int
outerPrecedence (a :: x
a :. as :: Context xs
as) =
Bool -> ShowS -> ShowS
showParen (Int
outerPrecedence Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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 " :. " 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 '[] -> Bool
== _ = Bool
True
instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
x1 :: x
x1 :. y1 :: Context xs
y1 == :: Context (a : as) -> Context (a : as) -> Bool
== x2 :: x
x2 :. y2 :: 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
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 (_ :. xs :: 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
x :. _) = val
x
x
data NamedContext (name :: Symbol) (subContext :: [*])
= NamedContext (Context subContext)
descendIntoNamedContext :: forall context name subContext .
HasContextEntry context (NamedContext name subContext) =>
Proxy (name :: Symbol) -> Context context -> Context subContext
descendIntoNamedContext :: Proxy name -> Context context -> Context subContext
descendIntoNamedContext Proxy context :: Context context
context =
let NamedContext subContext :: 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