diff --git a/servant/servant.cabal b/servant/servant.cabal index bfbec007..f7f76d27 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -84,6 +84,7 @@ library -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.4 && < 0.11 + , bifunctors >= 5.5.3 && < 5.6 , aeson >= 1.3.1.1 && < 1.5 , attoparsec >= 0.13.2.2 && < 0.14 , case-insensitive >= 1.2.0.11 && < 1.3 diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 5f8e393c..60152ac1 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -7,6 +7,15 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where +import Control.Applicative (liftA2) +import Data.Biapplicative + (Biapplicative (..)) +import Data.Bifoldable + (Bifoldable (..)) +import Data.Bifunctor + (Bifunctor (..)) +import Data.Bitraversable + (Bitraversable (..)) import Data.Semigroup (Semigroup (..)) import Data.Typeable @@ -33,6 +42,19 @@ instance (Monoid a, Monoid b) => Monoid (a :<|> b) where mempty = mempty :<|> mempty (a :<|> b) `mappend` (a' :<|> b') = (a `mappend` a') :<|> (b `mappend` b') +instance Bifoldable (:<|>) where + bifoldMap f g ~(a :<|> b) = f a `mappend` g b + +instance Bifunctor (:<|>) where + bimap f g ~(a :<|> b) = f a :<|> g b + +instance Biapplicative (:<|>) where + bipure = (:<|>) + (f :<|> g) <<*>> (a :<|> b) = f a :<|> g b + +instance Bitraversable (:<|>) where + bitraverse f g ~(a :<|> b) = liftA2 (:<|>) (f a) (g b) + -- $setup -- >>> import Servant.API -- >>> import Data.Aeson