From 02e4281d513b887f2123ec7ab31b21a9c830f5a4 Mon Sep 17 00:00:00 2001
From: "Julian K. Arni" <jkarni@gmail.com>
Date: Mon, 22 Aug 2016 12:44:39 -0300
Subject: [PATCH] Custom type errors

---
 servant/src/Servant/API/TypeLevel.hs | 51 +++++++++++++++-------------
 1 file changed, 28 insertions(+), 23 deletions(-)

diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs
index 759d89c0..f61c9b51 100644
--- a/servant/src/Servant/API/TypeLevel.hs
+++ b/servant/src/Servant/API/TypeLevel.hs
@@ -110,7 +110,8 @@ type family IsSubList a b :: Constraint where
     IsSubList '[] b          = ()
     IsSubList (x ': xs) y    = Elem x y `And` IsSubList xs y
 
--- | Check that an eleme is an element of a list:
+#if !MIN_VERSION_base(4,9,0)
+-- | Check that a value is an element of a list:
 --
 -- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
 -- OK
@@ -121,13 +122,31 @@ type family IsSubList a b :: Constraint where
 --       arising from a use of ‘ok’
 -- ...
 type Elem e es = ElemGo e es es
+#else
+-- | Check that a value is an element of a list:
+--
+-- >>> ok (Proxy :: Proxy (Elem Bool '[Int, Bool]))
+-- OK
+--
+-- >>> ok (Proxy  :: Proxy (Elem String '[Int, Bool]))
+-- ...
+-- ... [Char] expected in list '[Int, Bool]
+-- ...
+type Elem e es = ElemGo e es es
+#endif
 
 -- 'orig' is used to store original list for better error messages
 type family ElemGo e es orig :: Constraint where
     ElemGo x (x ': xs) orig = ()
     ElemGo y (x ': xs) orig = ElemGo y xs orig
+#if MIN_VERSION_base(4,9,0)
+    -- Note [Custom Errors]
+    ElemGo x '[] orig       = TypeError ('ShowType x
+                                    ':<>: 'Text " expected in list "
+                                    ':<>: 'ShowType orig)
+#else
     ElemGo x '[] orig       = ElemNotFoundIn x orig
-
+#endif
 
 -- ** Logic
 
@@ -144,30 +163,16 @@ type family And (a :: Constraint) (b :: Constraint) :: Constraint where
 
 -- * Custom type errors
 
-#if MIN_VERSION_base(4,9,0)
--- GHC >= 8
-
-
-type ElemNotFoundIn val list = TypeError
-  (ShowType val :<>: Text " expected in list " :<>: ShowList list)
-
-
--- Utilities
-
-type family ShowListGo ls :: ErrorMessage where
-  ShowListGo '[] = Text ""
-  ShowListGo (x ': xs) = ShowType x :<>: Text ", " :<>: ShowListGo xs
-
-type ShowList ls = Text "[" :<>: ShowListGo ls :<>: Text "]"
-
-
-#else
-
--- GHC < 8
+#if !MIN_VERSION_base(4,9,0)
 class ElemNotFoundIn val list
-
 #endif
 
+{- Note [Custom Errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We might try to factor these our more cleanly, but the type synonyms and type
+families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048).
+-}
+
 -- $setup
 -- >>> import Data.Proxy
 -- >>> data OK = OK deriving (Show)