Merge pull request #893 from phadej/issue-887-type-error-servant-server-instances

Add two HasServer instances which won't ever exist

servant-docs/servant-docs.cabal

@@ -40,7 +40,7 @@ library
     , base-compat >= 0.9.1 && <0.10
     , aeson
     , aeson-pretty
-    , bytestring
+    , bytestring >= 0.10.4.0 && <0.11
     , case-insensitive
     , hashable
     , http-media >= 0.6
@@ -49,8 +49,8 @@ library
     , servant == 0.12.*
     , string-conversions
     , text
-    , unordered-containers
+    , unordered-containers >=0.2.5.0
-    , control-monad-omega == 0.3.*
+    , control-monad-omega >= 0.3.1 && <0.4
   if !impl(ghc >= 8.0)
     build-depends:
       semigroups          >=0.17 && <0.19

servant-server/src/Servant/Server/Internal.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE PolyKinds                  #-}
@@ -14,6 +13,14 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
 
+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
+#define HAS_TYPE_ERROR
+#endif
+
+#ifdef HAS_TYPE_ERROR
+{-# LANGUAGE UndecidableInstances       #-}
+#endif
+
 #include "overlapping-compat.h"
 
 module Servant.Server.Internal
@@ -87,6 +94,9 @@ import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
 
+#ifdef HAS_TYPE_ERROR
+import GHC.TypeLits (TypeError, ErrorMessage (..))
+#endif
 
 class HasServer api context where
   type ServerT api (m :: * -> *) :: *
@@ -703,3 +713,75 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
       subContext = descendIntoNamedContext (Proxy :: Proxy name) context
 
   hoistServerWithContext _ _ nt s = hoistServerWithContext (Proxy :: Proxy subApi) (Proxy :: Proxy subContext) nt s
+
+-------------------------------------------------------------------------------
+-- TypeError helpers
+-------------------------------------------------------------------------------
+
+#ifdef HAS_TYPE_ERROR
+-- | This instance catches mistakes when there are non-saturated
+-- type applications on LHS of ':>'.
+--
+-- >>> serve (Proxy :: Proxy (Capture "foo" :> Get '[JSON] Int)) (error "...")
+-- ...
+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
+-- ...Maybe you haven't applied enough arguments to
+-- ...Capture "foo"
+-- ...
+--
+-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
+-- ...
+-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
+-- ...Maybe you haven't applied enough arguments to
+-- ...Capture "foo"
+-- ...
+-- 
+instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
+  where
+    type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
+    -- it doens't really matter what sub route we peak
+    route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)"
+    hoistServerWithContext _ _ _ = id
+
+-- Cannot have TypeError here, otherwise use of this symbol will error :)
+type HasServerArrowKindError arr =
+    'Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
+    ':$$: 'Text "Maybe you haven't applied enough arguments to"
+    ':$$: 'ShowType arr
+
+-- | This instance prevents from accidentally using '->' instead of ':>'
+--
+-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
+-- ...
+-- ...No instance HasServer (a -> b).
+-- ...Maybe you have used '->' instead of ':>' between
+-- ...Capture "foo" Int
+-- ...and
+-- ...Verb 'GET 200 '[JSON] Int
+-- ...
+--
+-- >>> undefined :: Server (Capture "foo" Int -> Get '[JSON] Int)
+-- ...
+-- ...No instance HasServer (a -> b).
+-- ...Maybe you have used '->' instead of ':>' between
+-- ...Capture "foo" Int
+-- ...and
+-- ...Verb 'GET 200 '[JSON] Int
+-- ...
+--
+instance TypeError (HasServerArrowTypeError a b) => HasServer (a -> b) context
+  where
+    type ServerT (a -> b) m = TypeError (HasServerArrowTypeError a b)
+    route _ _ _ = error "servant-server panic: impossible happened in HasServer (a -> b)"
+    hoistServerWithContext _ _ _ = id
+
+type HasServerArrowTypeError a b =
+    'Text "No instance HasServer (a -> b)."
+    ':$$: 'Text "Maybe you have used '->' instead of ':>' between "
+    ':$$: 'ShowType a
+    ':$$: 'Text "and"
+    ':$$: 'ShowType b
+#endif
+
+-- $setup
+-- >>> import Servant