From dc4b4be42ea851d29be62ece4bfbd1b6210fad08 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 19 Jan 2017 19:04:36 +0200 Subject: [PATCH 1/3] Improve formatting of haddock --- servant/src/Servant/API/Alternative.hs | 4 ++++ servant/src/Servant/Utils/Links.hs | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 8a8a693f..130f7529 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -7,6 +7,7 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where +import Data.Semigroup (Semigroup (..)) import Data.Typeable (Typeable) import Prelude () import Prelude.Compat @@ -23,6 +24,9 @@ data a :<|> b = a :<|> b deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded) infixr 8 :<|> +instance (Semigroup a, Semigroup b) => Semigroup (a :<|> b) where + (a :<|> b) <> (a' :<|> b') = (a <> a') :<|> (b <> b') + instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index 618bb2aa..ee7090e1 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -82,7 +82,7 @@ module Servant.Utils.Links ( -- * Building and using safe links -- - -- | Note that 'URI' is Network.URI.URI from the network-uri package. + -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink , URI(..) -- * Adding custom types From fdf86b0e155dadc490172f204d559e0858ef4b17 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 19 Jan 2017 19:05:01 +0200 Subject: [PATCH 2/3] Add Semigroup instances --- servant-client/servant-client.cabal | 3 +++ servant-client/src/Servant/Common/Req.hs | 7 ++++++- servant-docs/servant-docs.cabal | 4 ++++ servant-docs/src/Servant/Docs/Internal.hs | 14 +++++++++++--- 4 files changed, 24 insertions(+), 4 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 81069740..97f79174 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -59,6 +59,9 @@ library , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 , mtl + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 3fb8c5aa..b9dbba0b 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -16,6 +16,7 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch) import Data.Foldable (toList) +import Data.Semigroup (Semigroup (..)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Except @@ -27,7 +28,7 @@ import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl (..)) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) import Data.String -import Data.String.Conversions +import Data.String.Conversions (cs) import Data.Proxy import Data.Text (Text) import Data.Text.Encoding @@ -214,6 +215,10 @@ instance MonadBaseControl IO ClientM where -- restoreM :: StM ClientM a -> ClientM a restoreM st = ClientM (restoreM st) +-- | Try clients in order, last error is preserved. +instance Semigroup (ClientM a) where + a <> b = a `catchError` \_ -> b + runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 5981fbe9..719ea038 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -33,6 +33,7 @@ library , Servant.Docs.Internal.Pretty build-depends: base >=4.7 && <5 + , base-compat >= 0.9.1 && <0.10 , aeson , aeson-pretty , bytestring @@ -46,6 +47,9 @@ library , text , unordered-containers , control-monad-omega == 0.3.* + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.16.2.2 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 502c540f..2884473c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -20,6 +20,8 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where +import Prelude () +import Prelude.Compat import Control.Applicative import Control.Arrow (second) import Control.Lens (makeLenses, mapped, over, traversed, view, (%~), @@ -30,9 +32,10 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.CaseInsensitive as CI import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) -import Data.List +import Data.List.Compat (intercalate, intersperse, sort) import Data.Maybe -import Data.Monoid +import Data.Monoid (All (..), Any (..), Sum (..), Product (..), First (..), Last (..), Dual (..)) +import Data.Semigroup (Semigroup (..)) import Data.Ord (comparing) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions (cs) @@ -102,8 +105,11 @@ data API = API , _apiEndpoints :: HashMap Endpoint Action } deriving (Eq, Show) +instance Semigroup API where + (<>) = mappend + instance Monoid API where - API a1 b1 `mappend` API a2 b2 = API (a1 <> a2) (b1 <> b2) + API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2) mempty = API mempty mempty -- | An empty 'API' @@ -162,6 +168,8 @@ data DocNote = DocNote -- These are intended to be built using extraInfo. -- Multiple ExtraInfo may be combined with the monoid instance. newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action) +instance Semigroup (ExtraInfo a) where + (<>) = mappend instance Monoid (ExtraInfo a) where mempty = ExtraInfo mempty ExtraInfo a `mappend` ExtraInfo b = From 6fafaec51ada3025b1087e162daf49eba1af87f1 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 20 Jan 2017 14:26:26 +0200 Subject: [PATCH 3/3] Change Semigroup (ClientM a) to Alt ClientM --- servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Common/Req.hs | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 97f79174..f48d69a0 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -52,6 +52,7 @@ library , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 + , semigroupoids >= 4.3 && < 5.2 , servant == 0.9.* , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index b9dbba0b..f3de9687 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -16,7 +16,8 @@ import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch) import Data.Foldable (toList) -import Data.Semigroup (Semigroup (..)) +import Data.Functor.Alt (Alt (..)) +import Data.Semigroup ((<>)) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Trans.Except @@ -216,8 +217,8 @@ instance MonadBaseControl IO ClientM where restoreM st = ClientM (restoreM st) -- | Try clients in order, last error is preserved. -instance Semigroup (ClientM a) where - a <> b = a `catchError` \_ -> b +instance Alt ClientM where + a b = a `catchError` \_ -> b runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm