diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 7b3e30f5..0018ed5f 100644 --- a/servant-docs/servant-docs.cabal +++ b/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 - , control-monad-omega == 0.3.* + , unordered-containers >=0.2.5.0 + , control-monad-omega >= 0.3.1 && <0.4 if !impl(ghc >= 8.0) build-depends: semigroups >=0.17 && <0.19 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index cf454fe3..ba005ff0 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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