Merge branch 'issue-cdepillabout#6-grouped-throwing' into custom

src/Servant/Checked/Exceptions/Internal/Servant/API.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 
 {- |
 Module      :  Servant.Checked.Exceptions.Internal.Servant.API
@@ -16,6 +18,10 @@ This module defines the 'Throws' and 'Throwing' types.
 
 module Servant.Checked.Exceptions.Internal.Servant.API where
 
+import Servant.API ((:>))
+
+import Servant.Checked.Exceptions.Internal.Util (Snoc)
+
 -- | 'Throws' is used in Servant API definitions and signifies that an API will
 -- throw the given error.
 --
@@ -28,3 +34,12 @@ data Throws (e :: *)
 
 -- | This is used internally and should not be used by end-users.
 data Throwing (e :: [*])
+
+-- | Used by the 'HasServer' and 'HasClient' instances for
+-- @'Throwing' es ':>' api ':>' apis@ to detect @'Throwing' es@ followed
+-- immediately by @'Throws' e@.
+type family ThrowingNonterminal api where
+  ThrowingNonterminal (Throwing es :> Throws e :> api) =
+    Throwing (Snoc es e) :> api
+  ThrowingNonterminal (Throwing es :> c :> api) =
+    c :> Throwing es :> api

src/Servant/Checked/Exceptions/Internal/Servant/Client.hs

@@ -27,14 +27,13 @@ This module only exports 'HasClient' instances for 'Throws' and 'Throwing'.
 module Servant.Checked.Exceptions.Internal.Servant.Client where
 
 import Data.Proxy (Proxy(Proxy))
-import Servant.API (Verb, (:>))
+import Servant.API (Verb, (:>), (:<|>))
 import Servant.Client (HasClient(clientWithRoute, Client))
 import Servant.Common.Req (Req)
 
 import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
 import Servant.Checked.Exceptions.Internal.Servant.API
-       (Throws, Throwing)
-import Servant.Checked.Exceptions.Internal.Util (Snoc)
+       (Throws, Throwing, ThrowingNonterminal)
 
 -- TODO: Make sure to also account for when headers are being used.
 
@@ -63,17 +62,33 @@ instance (HasClient (Verb method status ctypes (Envelope es a))) =>
   clientWithRoute Proxy =
     clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
 
+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
+-- branch of the API.
+instance HasClient ((Throwing es :> api1) :<|> (Throwing es :> api2)) =>
+    HasClient (Throwing es :> (api1 :<|> api2)) where
+
+  type Client (Throwing es :> (api1 :<|> api2)) =
+    Client ((Throwing es :> api1) :<|> (Throwing es :> api2))
+
+  clientWithRoute
+    :: Proxy (Throwing es :> (api1 :<|> api2))
+    -> Req
+    -> Client ((Throwing es :> api1) :<|> (Throwing es :> api2))
+  clientWithRoute _ =
+    clientWithRoute (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
+
 -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
--- @e@ onto the @es@.
-instance (HasClient (Throwing (Snoc es e) :> api)) =>
-    HasClient (Throwing es :> Throws e :> api) where
+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
+-- combinator, push it down so it is closer to the 'Verb'.
+instance HasClient (ThrowingNonterminal (Throwing es :> api :> apis)) =>
+    HasClient (Throwing es :> api :> apis) where
 
-  type Client (Throwing es :> Throws e :> api) =
-    Client (Throwing (Snoc es e) :> api)
+  type Client (Throwing es :> api :> apis) =
+    Client (ThrowingNonterminal (Throwing es :> api :> apis))
 
   clientWithRoute
-    :: Proxy (Throwing es :> Throws e :> api)
+    :: Proxy (Throwing es :> api :> apis)
     -> Req
-    -> Client (Throwing (Snoc es e) :> api)
-  clientWithRoute Proxy =
-    clientWithRoute (Proxy :: Proxy (Throwing (Snoc es e) :> api))
+    -> Client (ThrowingNonterminal (Throwing es :> api :> apis))
+  clientWithRoute _ =
+    clientWithRoute (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

src/Servant/Checked/Exceptions/Internal/Servant/Server.hs

@@ -30,12 +30,11 @@ import Data.Proxy (Proxy(Proxy))
 import Servant.Server.Internal.Router (Router)
 import Servant.Server.Internal.RoutingApplication (Delayed)
 import Servant
-       (Context, Handler, HasServer(..), ServerT, Verb, (:>))
+       (Context, Handler, HasServer(..), ServerT, Verb, (:>), (:<|>))
 
 import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
 import Servant.Checked.Exceptions.Internal.Servant.API
-       (Throws, Throwing)
-import Servant.Checked.Exceptions.Internal.Util (Snoc)
+       (Throws, Throwing, ThrowingNonterminal)
 
 -- TODO: Make sure to also account for when headers are being used.
 
@@ -68,17 +67,33 @@ instance (HasServer (Verb method status ctypes (Envelope es a)) context) =>
     -> Router env
   route _ = route (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
 
+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
+-- branch of the API.
+instance HasServer ((Throwing es :> api1) :<|> (Throwing es :> api2)) context =>
+    HasServer (Throwing es :> (api1 :<|> api2)) context where
+
+  type ServerT (Throwing es :> (api1 :<|> api2)) m =
+    ServerT ((Throwing es :> api1) :<|> (Throwing es :> api2)) m
+
+  route
+    :: Proxy (Throwing es :> (api1 :<|> api2))
+    -> Context context
+    -> Delayed env (ServerT ((Throwing es :> api1) :<|> (Throwing es :> api2)) Handler)
+    -> Router env
+  route _ = route (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
+
 -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
--- @e@ onto the @es@.
-instance (HasServer (Throwing (Snoc es e) :> api) context) =>
-    HasServer (Throwing es :> Throws e :> api) context where
+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
+-- combinator, push it down so it is closer to the 'Verb'.
+instance HasServer (ThrowingNonterminal (Throwing es :> api :> apis)) context =>
+    HasServer (Throwing es :> api :> apis) context where
 
-  type ServerT (Throwing es :> Throws e :> api) m =
-    ServerT (Throwing (Snoc es e) :> api) m
+  type ServerT (Throwing es :> api :> apis) m =
+    ServerT (ThrowingNonterminal (Throwing es :> api :> apis)) m
 
   route
-    :: Proxy (Throwing es :> Throws e :> api)
+    :: Proxy (Throwing es :> api :> apis)
     -> Context context
-    -> Delayed env (ServerT (Throwing (Snoc es e) :> api) Handler)
+    -> Delayed env (ServerT (ThrowingNonterminal (Throwing es :> api :> apis)) Handler)
     -> Router env
-  route _ = route (Proxy :: Proxy (Throwing (Snoc es e) :> api))
+  route _ = route (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))