From 43895c83f9ec33936951c1eb216c7861fbd9962e Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 20 Jan 2018 18:33:15 +0200 Subject: [PATCH 1/2] Add two HasServer instances which won't ever exist Resolves https://github.com/haskell-servant/servant/issues/887 --- servant-server/src/Servant/Server/Internal.hs | 57 ++++++++++++++++++- 1 file changed, 56 insertions(+), 1 deletion(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index cf454fe3..98dace1b 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 #-} @@ -13,6 +12,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} #include "overlapping-compat.h" @@ -87,6 +87,10 @@ import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr +#if MIN_VERSION_base(4,9,0) +import Data.Void +import GHC.TypeLits (TypeError, ErrorMessage (..)) +#endif class HasServer api context where type ServerT api (m :: * -> *) :: * @@ -703,3 +707,54 @@ 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 +------------------------------------------------------------------------------- + +#if MIN_VERSION_base(4,9,0) +-- | 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" +-- ... +instance TypeError + ('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) + => HasServer ((arr :: k -> l) :> api) context + where + type ServerT (arr :> api) m = Void + -- it doens't really matter what sub route we peak + route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d) + hoistServerWithContext _ _ _ = id + +-- | 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 +-- ... +instance TypeError + ('Text "No instance HasServer (a -> b)." + ':$$: 'Text "Maybe you have used '->' instead of ':>' between " + ':$$: 'ShowType a + ':$$: 'Text "and" + ':$$: 'ShowType b) + => HasServer (a -> b) context + where + type ServerT (a -> b) m = Void + route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d) + hoistServerWithContext _ _ _ = id +#endif + +-- $setup +-- >>> import Servant From 6533d4bee5cdde3807a5375ee07753b2cd39f79c Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 22 Jan 2018 13:25:53 +0200 Subject: [PATCH 2/2] Void -> TypeError This doesn't work on GHC-8.0. I have trouble finding a ticket though. See https://ghc.haskell.org/trac/ghc/wiki/Proposal/CustomTypeErrors#DesignquestionsRAE --- servant-docs/servant-docs.cabal | 6 +- servant-server/src/Servant/Server/Internal.hs | 63 +++++++++++++------ 2 files changed, 48 insertions(+), 21 deletions(-) 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 98dace1b..ba005ff0 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -12,7 +12,14 @@ {-# LANGUAGE TupleSections #-} {-# 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" @@ -87,8 +94,7 @@ import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -#if MIN_VERSION_base(4,9,0) -import Data.Void +#ifdef HAS_TYPE_ERROR import GHC.TypeLits (TypeError, ErrorMessage (..)) #endif @@ -712,7 +718,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA -- TypeError helpers ------------------------------------------------------------------------------- -#if MIN_VERSION_base(4,9,0) +#ifdef HAS_TYPE_ERROR -- | This instance catches mistakes when there are non-saturated -- type applications on LHS of ':>'. -- @@ -722,17 +728,27 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA -- ...Maybe you haven't applied enough arguments to -- ...Capture "foo" -- ... -instance TypeError - ('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) - => HasServer ((arr :: k -> l) :> api) context +-- +-- >>> 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 = Void + type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) -- it doens't really matter what sub route we peak - route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d) + 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 "...") @@ -743,17 +759,28 @@ instance TypeError -- ...and -- ...Verb 'GET 200 '[JSON] Int -- ... -instance TypeError - ('Text "No instance HasServer (a -> b)." +-- +-- >>> 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) - => HasServer (a -> b) context - where - type ServerT (a -> b) m = Void - route Proxy context d = route (Proxy :: Proxy Raw) context (vacuous d) - hoistServerWithContext _ _ _ = id + ':$$: 'ShowType b #endif -- $setup