----------------------------------------------------------------------------- -- | -- Module : Data.Bifunctor.Apply -- Copyright : (C) 2011 Edward Kmett, -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : provisional -- Portability : portable -- ---------------------------------------------------------------------------- module Data.Bifunctor.Apply ( -- * Biappliable bifunctors Biapply(..) , (<<$>>) , (<<..>>) , bilift2 , bilift3 , module Data.Bifunctor ) where import Control.Applicative import Data.Bifunctor import Data.Semigroup import Data.Tagged infixl 4 <<$>>, <<.>>, <<., .>>, <<..>> (<<$>>) :: (a -> b) -> a -> b (<<$>>) = id {-# INLINE (<<$>>) #-} class Bifunctor p => Biapply p where (<<.>>) :: p (a -> b) (c -> d) -> p a c -> p b d -- | -- @ -- a '.>' b ≡ 'const' 'id' '<$>' a '<.>' b -- @ (.>>) :: p a b -> p c d -> p c d a .>> b = bimap (const id) (const id) <<$>> a <<.>> b {-# INLINE (.>>) #-} -- | -- @ -- a '<.' b ≡ 'const' '<$>' a '<.>' b -- @ (<<.) :: p a b -> p c d -> p a b a <<. b = bimap const const <<$>> a <<.>> b {-# INLINE (<<.) #-} (<<..>>) :: Biapply p => p a c -> p (a -> b) (c -> d) -> p b d (<<..>>) = bilift2 (flip id) (flip id) {-# INLINE (<<..>>) #-} -- | Lift binary functions bilift2 :: Biapply w => (a -> b -> c) -> (d -> e -> f) -> w a d -> w b e -> w c f bilift2 f g a b = bimap f g <<$>> a <<.>> b {-# INLINE bilift2 #-} -- | Lift ternary functions bilift3 :: Biapply w => (a -> b -> c -> d) -> (e -> f -> g -> h) -> w a e -> w b f -> w c g -> w d h bilift3 f g a b c = bimap f g <<$>> a <<.>> b <<.>> c {-# INLINE bilift3 #-} instance Biapply (,) where (f, g) <<.>> (a, b) = (f a, g b) {-# INLINE (<<.>>) #-} instance Semigroup x => Biapply ((,,) x) where (x, f, g) <<.>> (x', a, b) = (x <> x', f a, g b) {-# INLINE (<<.>>) #-} instance (Semigroup x, Semigroup y) => Biapply ((,,,) x y) where (x, y, f, g) <<.>> (x', y', a, b) = (x <> x', y <> y', f a, g b) {-# INLINE (<<.>>) #-} instance (Semigroup x, Semigroup y, Semigroup z) => Biapply ((,,,,) x y z) where (x, y, z, f, g) <<.>> (x', y', z', a, b) = (x <> x', y <> y', z <> z', f a, g b) {-# INLINE (<<.>>) #-} instance Biapply Const where Const f <<.>> Const x = Const (f x) {-# INLINE (<<.>>) #-} instance Biapply Tagged where Tagged f <<.>> Tagged x = Tagged (f x) {-# INLINE (<<.>>) #-}