From 9d9e3b92dc1edc6d0531dd96805b61a7d0b379db Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 3 May 2017 10:57:58 -0700 Subject: [PATCH 1/2] Add additional HasServer instances for Throwing These instances cover uses of (:<|>) as well as sequential uses of (:>). The latter instance uses a helper type family to avoid overlapping with the instance for Throwing followed by Throws. closes #6 --- .../Exceptions/Internal/Servant/Server.hs | 42 +++++++++++++++---- 1 file changed, 33 insertions(+), 9 deletions(-) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs index c75611d..06cb88f 100644 --- a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +++ b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs @@ -30,7 +30,7 @@ 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 @@ -68,17 +68,41 @@ 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))) + +-- | Used by the 'HasServer' instance 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 + -- | 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))) From cf10d4afdaaf8a2e7c5d27d4335e975e5eca550e Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 3 May 2017 14:45:55 -0700 Subject: [PATCH 2/2] Add new HasClient instances to match the new HasServer instances --- .../Exceptions/Internal/Servant/API.hs | 17 +++++++- .../Exceptions/Internal/Servant/Client.hs | 39 +++++++++++++------ .../Exceptions/Internal/Servant/Server.hs | 11 +----- 3 files changed, 44 insertions(+), 23 deletions(-) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/API.hs b/src/Servant/Checked/Exceptions/Internal/Servant/API.hs index 0462e00..13207f6 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 PolyKinds #-} +{-# 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 06cb88f..cb2fda5 100644 --- a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs +++ b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs @@ -34,8 +34,7 @@ import Servant 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. @@ -83,14 +82,6 @@ instance HasServer ((Throwing es :> api1) :<|> (Throwing es :> api2)) context => -> Router env route _ = route (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2))) --- | Used by the 'HasServer' instance 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 - -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the -- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other -- combinator, push it down so it is closer to the 'Verb'.