From 6533d4bee5cdde3807a5375ee07753b2cd39f79c Mon Sep 17 00:00:00 2001
From: Oleg Grenrus <oleg.grenrus@iki.fi>
Date: Mon, 22 Jan 2018 13:25:53 +0200
Subject: [PATCH] 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