diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/API.hs b/src/Servant/Checked/Exceptions/Internal/Servant/API.hs index 0462e00..80c9fc1 100644 --- a/src/Servant/Checked/Exceptions/Internal/Servant/API.hs +++ b/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 diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Client.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Client.hs index 1388c15..ea10f05 100644 --- a/src/Servant/Checked/Exceptions/Internal/Servant/Client.hs +++ b/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))) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs index c75611d..cb2fda5 100644 --- a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +++ b/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)))