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
This commit is contained in:
parent
43895c83f9
commit
6533d4bee5
2 changed files with 48 additions and 21 deletions
|
@ -40,7 +40,7 @@ library
|
||||||
, base-compat >= 0.9.1 && <0.10
|
, base-compat >= 0.9.1 && <0.10
|
||||||
, aeson
|
, aeson
|
||||||
, aeson-pretty
|
, aeson-pretty
|
||||||
, bytestring
|
, bytestring >= 0.10.4.0 && <0.11
|
||||||
, case-insensitive
|
, case-insensitive
|
||||||
, hashable
|
, hashable
|
||||||
, http-media >= 0.6
|
, http-media >= 0.6
|
||||||
|
@ -49,8 +49,8 @@ library
|
||||||
, servant == 0.12.*
|
, servant == 0.12.*
|
||||||
, string-conversions
|
, string-conversions
|
||||||
, text
|
, 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)
|
if !impl(ghc >= 8.0)
|
||||||
build-depends:
|
build-depends:
|
||||||
semigroups >=0.17 && <0.19
|
semigroups >=0.17 && <0.19
|
||||||
|
|
|
@ -12,7 +12,14 @@
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
|
||||||
|
#define HAS_TYPE_ERROR
|
||||||
|
#endif
|
||||||
|
|
||||||
|
#ifdef HAS_TYPE_ERROR
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
#endif
|
||||||
|
|
||||||
#include "overlapping-compat.h"
|
#include "overlapping-compat.h"
|
||||||
|
|
||||||
|
@ -87,8 +94,7 @@ import Servant.Server.Internal.Router
|
||||||
import Servant.Server.Internal.RoutingApplication
|
import Servant.Server.Internal.RoutingApplication
|
||||||
import Servant.Server.Internal.ServantErr
|
import Servant.Server.Internal.ServantErr
|
||||||
|
|
||||||
#if MIN_VERSION_base(4,9,0)
|
#ifdef HAS_TYPE_ERROR
|
||||||
import Data.Void
|
|
||||||
import GHC.TypeLits (TypeError, ErrorMessage (..))
|
import GHC.TypeLits (TypeError, ErrorMessage (..))
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
@ -712,7 +718,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
|
||||||
-- TypeError helpers
|
-- TypeError helpers
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
#if MIN_VERSION_base(4,9,0)
|
#ifdef HAS_TYPE_ERROR
|
||||||
-- | This instance catches mistakes when there are non-saturated
|
-- | This instance catches mistakes when there are non-saturated
|
||||||
-- type applications on LHS of ':>'.
|
-- 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
|
-- ...Maybe you haven't applied enough arguments to
|
||||||
-- ...Capture "foo"
|
-- ...Capture "foo"
|
||||||
-- ...
|
-- ...
|
||||||
instance TypeError
|
--
|
||||||
('Text "Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'."
|
-- >>> undefined :: Server (Capture "foo" :> Get '[JSON] Int)
|
||||||
':$$: 'Text "Maybe you haven't applied enough arguments to"
|
-- ...
|
||||||
':$$: 'ShowType arr)
|
-- ...Expected something of kind Symbol or *, got: k -> l on the LHS of ':>'.
|
||||||
=> HasServer ((arr :: k -> l) :> api) context
|
-- ...Maybe you haven't applied enough arguments to
|
||||||
|
-- ...Capture "foo"
|
||||||
|
-- ...
|
||||||
|
--
|
||||||
|
instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
|
||||||
where
|
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
|
-- 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
|
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 ':>'
|
-- | This instance prevents from accidentally using '->' instead of ':>'
|
||||||
--
|
--
|
||||||
-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
|
-- >>> serve (Proxy :: Proxy (Capture "foo" Int -> Get '[JSON] Int)) (error "...")
|
||||||
|
@ -743,17 +759,28 @@ instance TypeError
|
||||||
-- ...and
|
-- ...and
|
||||||
-- ...Verb 'GET 200 '[JSON] Int
|
-- ...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 "
|
':$$: 'Text "Maybe you have used '->' instead of ':>' between "
|
||||||
':$$: 'ShowType a
|
':$$: 'ShowType a
|
||||||
':$$: 'Text "and"
|
':$$: 'Text "and"
|
||||||
':$$: 'ShowType b)
|
':$$: '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
|
#endif
|
||||||
|
|
||||||
-- $setup
|
-- $setup
|
||||||
|
|
Loading…
Reference in a new issue