From d4ff7776de7907f110dfc2101d2f7737c82c1b73 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 3 May 2017 14:45:55 -0700 Subject: [PATCH] Add new HasClient instances to match the new HasServer instances --- .../Exceptions/Internal/Servant/API.hs | 15 +++++++ .../Exceptions/Internal/Servant/Client.hs | 39 +++++++++++++------ .../Exceptions/Internal/Servant/Server.hs | 11 +----- 3 files changed, 43 insertions(+), 22 deletions(-) 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 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'.