@@ -12,7 +12,14 @@
1212{-# LANGUAGE TupleSections #-}
1313{-# LANGUAGE TypeFamilies #-}
1414{-# LANGUAGE TypeOperators #-}
15+
16+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
17+#define HAS_TYPE_ERROR
18+#endif
19+
20+#ifdef HAS_TYPE_ERROR
1521{-# LANGUAGE UndecidableInstances #-}
22+#endif
1623
1724#include "overlapping-compat.h"
1825
@@ -87,8 +94,7 @@ import Servant.Server.Internal.Router
8794import Servant.Server.Internal.RoutingApplication
8895import Servant.Server.Internal.ServantErr
8996
90−#if MIN_VERSION_base(4,9,0)
91−import Data.Void
97+#ifdef HAS_TYPE_ERROR
9298import GHC.TypeLits (TypeError, ErrorMessage (..))
9399#endif
94100
@@ -712,7 +718,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
712718-- TypeError helpers
713719-------------------------------------------------------------------------------
714720
715−#if MIN_VERSION_base(4,9,0)
721+#ifdef HAS_TYPE_ERROR
716722-- | This instance catches mistakes when there are non-saturated
717723-- type applications on LHS of ':>'.
718724--
@@ -722,17 +728,27 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
722728-- ...Maybe you haven't applied enough arguments to
723729-- ...Capture "foo"
724730-- ...
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
731+--
732+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
733+-- ...
734+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
735+-- ...Maybe you haven't applied enough arguments to
736+-- ...Capture "foo"
737+-- ...
738+--
739+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
730740 where
731− type ServerT (arr :> api) m = Void
741+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
732742 -- it doens't really matter what sub route we peak
733− route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d)
743+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
734744 hoistServerWithContext _ _ _ = id
735745
746+-- Cannot have TypeError here, otherwise use of this symbol will error :)
747+type HasServerArrowKindError arr =
748+ 'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
749+ ':$$: 'Text "Maybe you haven't applied enough arguments to"
750+ ':$$: 'ShowType arr
751+
736752-- | This instance prevents from accidentally using '->' instead of ':>'
737753--
738754-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
@@ -743,17 +759,28 @@ instance TypeError
743759-- ...and
744760-- ...Verb 'GET 200 '[JSON] Int
745761-- ...
746−instance TypeError
747− ('Text "No instance HasServer (a -> b)."
762+--
763+-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
764+-- ...
765+-- ...No instance HasServer (a -> b).
766+-- ...Maybe you have used '->' instead of ':>' between
767+-- ...Capture "foo" Int
768+-- ...and
769+-- ...Verb 'GET 200 '[JSON] Int
770+-- ...
771+--
772+instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
773+ where
774+ type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
775+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
776+ hoistServerWithContext _ _ _ = id
777+
778+type HasServerArrowTypeError a b =
779+ 'Text "No instance HasServer (a -> b)."
748780 ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
749781 ':$$: 'ShowType a
750782 ':$$: '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
783+ ':$$: 'ShowType b
757784#endif
758785
759786-- $setup