module Servant.Utils.Links (
mkLink
, Link
, ValidLinkIn()
, VLinkHelper(..)
, IsElem
, IsLink
)where
import Data.Proxy ( Proxy(..) )
import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
import Servant.API.Capture ( Capture )
import Servant.API.ReqBody ( ReqBody )
import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag )
import Servant.API.MatrixParam ( MatrixParam, MatrixParams, MatrixFlag )
import Servant.API.Get ( Get )
import Servant.API.Post ( Post )
import Servant.API.Put ( Put )
import Servant.API.Delete ( Delete )
import Servant.API.Sub ( type (:>) )
import Servant.API.Alternative ( type (:<|>) )
type family Or a b where
Or 'False 'False = 'False
Or 'True b = 'True
Or a 'True = 'True
type family And a b where
And 'True 'True = 'True
And a 'False = 'False
And 'False b = 'False
type family IsElem a s where
IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
IsElem (e :> sa) (e :> sb) = IsElem sa sb
IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
IsElem sa (ReqBody x :> sb) = IsElem sa sb
IsElem sa (QueryParam x y :> sb) = IsElem sa sb
IsElem sa (QueryParams x y :> sb) = IsElem sa sb
IsElem sa (QueryFlag x :> sb) = IsElem sa sb
IsElem sa (MatrixParam x y :> sb) = IsElem sa sb
IsElem sa (MatrixParams x y :> sb) = IsElem sa sb
IsElem sa (MatrixFlag x :> sb) = IsElem sa sb
IsElem e e = 'True
IsElem e a = 'False
type family IsLink'' l where
IsLink'' (e :> Get x) = IsLink' e
IsLink'' (e :> Post x) = IsLink' e
IsLink'' (e :> Put x) = IsLink' e
IsLink'' (e :> Delete) = IsLink' e
IsLink'' a = 'False
type family IsLink' e where
IsLink' (f :: Symbol) = 'True
type family IsLink e where
IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b))
(IsLink'' (a :> b))
class ValidLinkIn f s where
mkLink :: f -> s -> Link
instance ( IsElem f s ~ 'True
, IsLink f ~ 'True
, VLinkHelper f) => ValidLinkIn f s where
mkLink _ _ = Link (vlh (Proxy :: Proxy f))
data Link = Link String deriving Show
class VLinkHelper f where
vlh :: forall proxy. proxy f -> String
instance (KnownSymbol s, VLinkHelper e) => VLinkHelper (s :> e) where
vlh _ = "/" ++ symbolVal (Proxy :: Proxy s) ++ vlh (Proxy :: Proxy e)
instance VLinkHelper (Get x) where
vlh _ = ""
instance VLinkHelper (Post x) where
vlh _ = ""