git.iko.soy/typeable/servant
on master help sign in
Add two HasServer instances which won't ever exist
43895c8Oleg Grenrus
servant-server/src/Servant/Server/Internal.hs+56−1
compare with master
unifiedsplit
@@ -4,7 +4,6 @@
4{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
10{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
@@ -13,6 +12,7 @@
13{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE UndecidableInstances #-}
16
16
17#include "overlapping-compat.h"
17#include "overlapping-compat.h"
18
18
@@ -87,6 +87,10 @@ import Servant.Server.Internal.Router
87import Servant.Server.Internal.RoutingApplication
87import Servant.Server.Internal.RoutingApplication
88import Servant.Server.Internal.ServantErr
88import Servant.Server.Internal.ServantErr
89
89
90+#if MIN_VERSION_base(4,9,0)
91+import Data.Void
92+import GHC.TypeLits (TypeError, ErrorMessage (..))
93+#endif
90
94
91class HasServer api context where
95class HasServer api context where
92 type ServerT api (m :: * -> *) :: *
96 type ServerT api (m :: * -> *) :: *
@@ -703,3 +707,54 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
703 subContext = descendIntoNamedContext (Proxy :: Proxy name) context
707 subContext = descendIntoNamedContext (Proxy :: Proxy name) context
704
708
705 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
709 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
710+
711+-------------------------------------------------------------------------------
712+-- TypeError helpers
713+-------------------------------------------------------------------------------
714+
715+#if MIN_VERSION_base(4,9,0)
716+-- | This instance catches mistakes when there are non-saturated
717+-- type applications on LHS of ':>'.
718+--
719+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
720+-- ...
721+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
722+-- ...Maybe you haven't applied enough arguments to
723+-- ...Capture "foo"
724+-- ...
725+instance TypeError
726+ ('Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
727+ ':$$: 'Text "Maybe you haven't applied enough arguments to"
728+ ':$$: 'ShowType arr)
729+ => HasServer ((arr :: k -> l) :> api) context
730+ where
731+ type ServerT (arr :> api) m = Void
732+ -- it doens't really matter what sub route we peak
733+ route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d)
734+ hoistServerWithContext _ _ _ = id
735+
736+-- | This instance prevents from accidentally using '->' instead of ':>'
737+--
738+-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
739+-- ...
740+-- ...No instance HasServer (a -> b).
741+-- ...Maybe you have used '->' instead of ':>' between
742+-- ...Capture "foo" Int
743+-- ...and
744+-- ...Verb 'GET 200 '[JSON] Int
745+-- ...
746+instance TypeError
747+ ('Text "No instance HasServer (a -> b)."
748+ ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
749+ ':$$: 'ShowType a
750+ ':$$: 'Text "and"
751+ ':$$: 'ShowType b)
752+ => HasServer (a -> b) context
753+ where
754+ type ServerT (a -> b) m = Void
755+ route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d)
756+ hoistServerWithContext _ _ _ = id
757+#endif
758+
759+-- $setup
760+-- >>> import Servant