git.iko.soy/servant
on master help sign in
Add constrainty Link implementation.
6785717Christian Marie
src/Servant/Utils/Links.hs+16−18
compare with master
unifiedsplit
@@ -1,4 +1,5 @@
1{-# LANGUAGE PolyKinds #-}
1{-# LANGUAGE PolyKinds #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
@@ -71,6 +72,7 @@ module Servant.Utils.Links (
71
72
72import Data.Proxy ( Proxy(..) )
73import Data.Proxy ( Proxy(..) )
73import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
74import GHC.TypeLits ( KnownSymbol, Symbol, symbolVal )
75+import GHC.Exts(Constraint)
74
76
75import Servant.API.Capture ( Capture )
77import Servant.API.Capture ( Capture )
76import Servant.API.ReqBody ( ReqBody )
78import Servant.API.ReqBody ( ReqBody )
@@ -85,19 +87,16 @@ import Servant.API.Raw ( Raw )
85import Servant.API.Alternative ( type (:<|>) )
87import Servant.API.Alternative ( type (:<|>) )
86
88
87
89
88−type family Or a b where
90+type family Or (a :: Constraint) (b :: Constraint) :: Constraint where
89− Or 'False 'False = 'False
91+ Or () b = ()
90− Or 'True b = 'True
91− Or a 'True = 'True
92+ Or a () = ()
92
93
93−type family And a b where
94+type family And (a :: Constraint) (b :: Constraint) :: Constraint where
94− And 'True 'True = 'True
95+ And () () = ()
95− And a 'False = 'False
96− And 'False b = 'False
97
96
98−type family IsElem' a s :: Bool
97+type family IsElem' a s :: Constraint
99
98
100−type family IsElem a s where
99+type family IsElem a s :: Constraint where
101 IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
100 IsElem e (sa :<|> sb) = Or (IsElem e sa) (IsElem e sb)
102 IsElem (e :> sa) (e :> sb) = IsElem sa sb
101 IsElem (e :> sa) (e :> sb) = IsElem sa sb
103 IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
102 IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
@@ -108,21 +107,20 @@ type family IsElem a s where
108 IsElem sa (MatrixParam x y :> sb) = IsElem sa sb
107 IsElem sa (MatrixParam x y :> sb) = IsElem sa sb
109 IsElem sa (MatrixParams x y :> sb) = IsElem sa sb
108 IsElem sa (MatrixParams x y :> sb) = IsElem sa sb
110 IsElem sa (MatrixFlag x :> sb) = IsElem sa sb
109 IsElem sa (MatrixFlag x :> sb) = IsElem sa sb
111− IsElem e e = 'True
110+ IsElem e e = ()
112 IsElem e a = IsElem' e a
111 IsElem e a = IsElem' e a
113
112
114−type family IsLink'' l where
113+type family IsLink'' l :: Constraint where
115 IsLink'' (e :> Get x) = IsLink' e
114 IsLink'' (e :> Get x) = IsLink' e
116 IsLink'' (e :> Post x) = IsLink' e
115 IsLink'' (e :> Post x) = IsLink' e
117 IsLink'' (e :> Put x) = IsLink' e
116 IsLink'' (e :> Put x) = IsLink' e
118 IsLink'' (e :> Delete) = IsLink' e
117 IsLink'' (e :> Delete) = IsLink' e
119 IsLink'' (e :> Raw) = IsLink' e
118 IsLink'' (e :> Raw) = IsLink' e
120− IsLink'' a = 'False
121
119
122−type family IsLink' e where
120+type family IsLink' e :: Constraint where
123− IsLink' (f :: Symbol) = 'True
121+ IsLink' (f :: Symbol) = ()
124
122
125−type family IsLink e where
123+type family IsLink e :: Constraint where
126 IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b))
124 IsLink (a :> b) = Or (And (IsLink' a) (IsLink'' b))
127 (IsLink'' (a :> b))
125 (IsLink'' (a :> b))
128
126
@@ -133,8 +131,8 @@ class ValidLinkIn f s where
133 mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f`
131 mkLink :: f -> s -> Link -- ^ This function will only typecheck if `f`
134 -- is an URI within `s`
132 -- is an URI within `s`
135
133
136−instance ( IsElem f s ~ 'True
134+instance ( IsElem f s
137− , IsLink f ~ 'True
135+ , IsLink f
138 , VLinkHelper f) => ValidLinkIn f s where
136 , VLinkHelper f) => ValidLinkIn f s where
139 mkLink _ _ = Link (vlh (Proxy :: Proxy f))
137 mkLink _ _ = Link (vlh (Proxy :: Proxy f))
140
138