Add Semigroup instances

This commit is contained in:
Oleg Grenrus 2017-01-19 19:05:01 +02:00
parent dc4b4be42e
commit fdf86b0e15
4 changed files with 24 additions and 4 deletions

View file

@ -59,6 +59,9 @@ library
, transformers-base >= 0.4.4 && < 0.5 , transformers-base >= 0.4.4 && < 0.5
, transformers-compat >= 0.4 && < 0.6 , transformers-compat >= 0.4 && < 0.6
, mtl , mtl
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.16.2.2 && <0.19
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -16,6 +16,7 @@ import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.Catch (MonadThrow, MonadCatch)
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Semigroup (Semigroup (..))
import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
@ -27,7 +28,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions (cs)
import Data.Proxy import Data.Proxy
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
@ -214,6 +215,10 @@ instance MonadBaseControl IO ClientM where
-- restoreM :: StM ClientM a -> ClientM a -- restoreM :: StM ClientM a -> ClientM a
restoreM st = ClientM (restoreM st) 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 :: ClientM a -> ClientEnv -> IO (Either ServantError a)
runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm

View file

@ -33,6 +33,7 @@ library
, Servant.Docs.Internal.Pretty , Servant.Docs.Internal.Pretty
build-depends: build-depends:
base >=4.7 && <5 base >=4.7 && <5
, base-compat >= 0.9.1 && <0.10
, aeson , aeson
, aeson-pretty , aeson-pretty
, bytestring , bytestring
@ -46,6 +47,9 @@ library
, text , text
, unordered-containers , unordered-containers
, control-monad-omega == 0.3.* , control-monad-omega == 0.3.*
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.16.2.2 && <0.19
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -20,6 +20,8 @@
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.Docs.Internal where module Servant.Docs.Internal where
import Prelude ()
import Prelude.Compat
import Control.Applicative import Control.Applicative
import Control.Arrow (second) import Control.Arrow (second)
import Control.Lens (makeLenses, mapped, over, traversed, view, (%~), 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 qualified Data.CaseInsensitive as CI
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.List import Data.List.Compat (intercalate, intersperse, sort)
import Data.Maybe 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.Ord (comparing)
import Data.Proxy (Proxy(Proxy)) import Data.Proxy (Proxy(Proxy))
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
@ -102,8 +105,11 @@ data API = API
, _apiEndpoints :: HashMap Endpoint Action , _apiEndpoints :: HashMap Endpoint Action
} deriving (Eq, Show) } deriving (Eq, Show)
instance Semigroup API where
(<>) = mappend
instance Monoid API where 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 mempty = API mempty mempty
-- | An empty 'API' -- | An empty 'API'
@ -162,6 +168,8 @@ data DocNote = DocNote
-- These are intended to be built using extraInfo. -- These are intended to be built using extraInfo.
-- Multiple ExtraInfo may be combined with the monoid instance. -- Multiple ExtraInfo may be combined with the monoid instance.
newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action) newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action)
instance Semigroup (ExtraInfo a) where
(<>) = mappend
instance Monoid (ExtraInfo a) where instance Monoid (ExtraInfo a) where
mempty = ExtraInfo mempty mempty = ExtraInfo mempty
ExtraInfo a `mappend` ExtraInfo b = ExtraInfo a `mappend` ExtraInfo b =