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:
Oleg Grenrus 2018-01-22 13:25:53 +02:00
parent 43895c83f9
commit 6533d4bee5
2 changed files with 48 additions and 21 deletions

View file

@ -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

View file

@ -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