@@ -4,7 +4,6 @@
44{-# LANGUAGE DeriveDataTypeable #-}
55{-# LANGUAGE FlexibleContexts #-}
66{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
87{-# LANGUAGE MultiParamTypeClasses #-}
98{-# LANGUAGE OverloadedStrings #-}
109{-# LANGUAGE PolyKinds #-}
@@ -14,6 +13,14 @@
1413{-# LANGUAGE TypeFamilies #-}
1514{-# LANGUAGE TypeOperators #-}
1615
16+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
17+#define HAS_TYPE_ERROR
18+#endif
19+
20+#ifdef HAS_TYPE_ERROR
21+{-# LANGUAGE UndecidableInstances #-}
22+#endif
23+
1724#include "overlapping-compat.h"
1825
1926module Servant.Server.Internal
@@ -87,6 +94,9 @@ import Servant.Server.Internal.Router
8794import Servant.Server.Internal.RoutingApplication
8895import Servant.Server.Internal.ServantErr
8996
97+#ifdef HAS_TYPE_ERROR
98+import GHC.TypeLits (TypeError, ErrorMessage (..))
99+#endif
90100
91101class HasServer api context where
92102 type ServerT api (m :: * -> *) :: *
@@ -703,3 +713,75 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
703713 subContext = descendIntoNamedContext (Proxy :: Proxy name) context
704714
705715 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
716+
717+-------------------------------------------------------------------------------
718+-- TypeError helpers
719+-------------------------------------------------------------------------------
720+
721+#ifdef HAS_TYPE_ERROR
722+-- | This instance catches mistakes when there are non-saturated
723+-- type applications on LHS of ':>'.
724+--
725+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
726+-- ...
727+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
728+-- ...Maybe you haven't applied enough arguments to
729+-- ...Capture "foo"
730+-- ...
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
740+ where
741+ type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
742+ -- it doens't really matter what sub route we peak
743+ route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
744+ hoistServerWithContext _ _ _ = id
745+
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+
752+-- | This instance prevents from accidentally using '->' instead of ':>'
753+--
754+-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
755+-- ...
756+-- ...No instance HasServer (a -> b).
757+-- ...Maybe you have used '->' instead of ':>' between
758+-- ...Capture "foo" Int
759+-- ...and
760+-- ...Verb 'GET 200 '[JSON] Int
761+-- ...
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)."
780+ ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
781+ ':$$: 'ShowType a
782+ ':$$: 'Text "and"
783+ ':$$: 'ShowType b
784+#endif
785+
786+-- $setup
787+-- >>> import Servant