git.iko.soy/servant
on master help sign in
Merge pull request #893 from phadej/issue-887-type-error-servant-server-instances
0a50e75Oleg Grenrus
servant-docs/servant-docs.cabal+3−3
compare with master
unifiedsplit
@@ -40,7 +40,7 @@ library
40 , base-compat >= 0.9.1 && <0.10
40 , base-compat >= 0.9.1 && <0.10
41 , aeson
41 , aeson
42 , aeson-pretty
42 , aeson-pretty
43− , bytestring
43+ , bytestring >= 0.10.4.0 && <0.11
44 , case-insensitive
44 , case-insensitive
45 , hashable
45 , hashable
46 , http-media >= 0.6
46 , http-media >= 0.6
@@ -49,8 +49,8 @@ library
49 , servant == 0.12.*
49 , servant == 0.12.*
50 , string-conversions
50 , string-conversions
51 , text
51 , text
52− , unordered-containers
52+ , unordered-containers >=0.2.5.0
53− , control-monad-omega == 0.3.*
53+ , control-monad-omega >= 0.3.1 && <0.4
54 if !impl(ghc >= 8.0)
54 if !impl(ghc >= 8.0)
55 build-depends:
55 build-depends:
56 semigroups >=0.17 && <0.19
56 semigroups >=0.17 && <0.19
servant-server/src/Servant/Server/Internal.hs+83−1
@@ -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 #-}
@@ -14,6 +13,14 @@
14{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
16
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
21+{-# LANGUAGE UndecidableInstances #-}
22+#endif
23+
17#include "overlapping-compat.h"
24#include "overlapping-compat.h"
18
25
19module Servant.Server.Internal
26module Servant.Server.Internal
@@ -87,6 +94,9 @@ import Servant.Server.Internal.Router
87import Servant.Server.Internal.RoutingApplication
94import Servant.Server.Internal.RoutingApplication
88import Servant.Server.Internal.ServantErr
95import Servant.Server.Internal.ServantErr
89
96
97+#ifdef HAS_TYPE_ERROR
98+import GHC.TypeLits (TypeError, ErrorMessage (..))
99+#endif
90
100
91class HasServer api context where
101class HasServer api context where
92 type ServerT api (m :: * -> *) :: *
102 type ServerT api (m :: * -> *) :: *
@@ -703,3 +713,75 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
703 subContext = descendIntoNamedContext (Proxy :: Proxy name) context
713 subContext = descendIntoNamedContext (Proxy :: Proxy name) context
704
714
705 hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
715 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