module Data.Functor.Contravariant (
Contravariant(..)
, phantom
, (>$<), (>$$<), ($<)
, Predicate(..)
, Comparison(..)
, defaultComparison
, Equivalence(..)
, defaultEquivalence
, comparisonEquivalence
, Op(..)
) where
import Control.Applicative
import Control.Category
import Data.Function (on)
import Data.Functor.Product
import Data.Functor.Sum
import Data.Functor.Compose
import Data.Monoid (Alt(..))
import Data.Proxy
import GHC.Generics
import Prelude hiding ((.),id)
class Contravariant f where
contramap :: (a -> b) -> f b -> f a
(>$) :: b -> f b -> f a
(>$) = contramap . const
phantom :: (Functor f, Contravariant f) => f a -> f b
phantom x = () <$ x $< ()
infixl 4 >$, $<, >$<, >$$<
($<) :: Contravariant f => f b -> b -> f a
($<) = flip (>$)
(>$<) :: Contravariant f => (a -> b) -> f b -> f a
(>$<) = contramap
(>$$<) :: Contravariant f => f b -> (a -> b) -> f a
(>$$<) = flip contramap
deriving instance Contravariant f => Contravariant (Alt f)
deriving instance Contravariant f => Contravariant (Rec1 f)
deriving instance Contravariant f => Contravariant (M1 i c f)
instance Contravariant V1 where
contramap _ x = case x of
instance Contravariant U1 where
contramap _ _ = U1
instance Contravariant (K1 i c) where
contramap _ (K1 c) = K1 c
instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where
contramap f (xs :*: ys) = contramap f xs :*: contramap f ys
instance (Functor f, Contravariant g) => Contravariant (f :.: g) where
contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)
instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where
contramap f (L1 xs) = L1 (contramap f xs)
contramap f (R1 ys) = R1 (contramap f ys)
instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where
contramap f (InL xs) = InL (contramap f xs)
contramap f (InR ys) = InR (contramap f ys)
instance (Contravariant f, Contravariant g)
=> Contravariant (Product f g) where
contramap f (Pair a b) = Pair (contramap f a) (contramap f b)
instance Contravariant (Const a) where
contramap _ (Const a) = Const a
instance (Functor f, Contravariant g) => Contravariant (Compose f g) where
contramap f (Compose fga) = Compose (fmap (contramap f) fga)
instance Contravariant Proxy where
contramap _ _ = Proxy
newtype Predicate a = Predicate { getPredicate :: a -> Bool }
instance Contravariant Predicate where
contramap f g = Predicate $ getPredicate g . f
instance Semigroup (Predicate a) where
Predicate p <> Predicate q = Predicate $ \a -> p a && q a
instance Monoid (Predicate a) where
mempty = Predicate $ const True
newtype Comparison a = Comparison { getComparison :: a -> a -> Ordering }
deriving instance Semigroup (Comparison a)
deriving instance Monoid (Comparison a)
instance Contravariant Comparison where
contramap f g = Comparison $ on (getComparison g) f
defaultComparison :: Ord a => Comparison a
defaultComparison = Comparison compare
newtype Equivalence a = Equivalence { getEquivalence :: a -> a -> Bool }
instance Contravariant Equivalence where
contramap f g = Equivalence $ on (getEquivalence g) f
instance Semigroup (Equivalence a) where
Equivalence p <> Equivalence q = Equivalence $ \a b -> p a b && q a b
instance Monoid (Equivalence a) where
mempty = Equivalence (\_ _ -> True)
defaultEquivalence :: Eq a => Equivalence a
defaultEquivalence = Equivalence (==)
comparisonEquivalence :: Comparison a -> Equivalence a
comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ
newtype Op a b = Op { getOp :: b -> a }
deriving instance Semigroup a => Semigroup (Op a b)
deriving instance Monoid a => Monoid (Op a b)
instance Category Op where
id = Op id
Op f . Op g = Op (g . f)
instance Contravariant (Op a) where
contramap f g = Op (getOp g . f)
instance Num a => Num (Op a b) where
Op f + Op g = Op $ \a -> f a + g a
Op f * Op g = Op $ \a -> f a * g a
Op f Op g = Op $ \a -> f a g a
abs (Op f) = Op $ abs . f
signum (Op f) = Op $ signum . f
fromInteger = Op . const . fromInteger
instance Fractional a => Fractional (Op a b) where
Op f / Op g = Op $ \a -> f a / g a
recip (Op f) = Op $ recip . f
fromRational = Op . const . fromRational
instance Floating a => Floating (Op a b) where
pi = Op $ const pi
exp (Op f) = Op $ exp . f
sqrt (Op f) = Op $ sqrt . f
log (Op f) = Op $ log . f
sin (Op f) = Op $ sin . f
tan (Op f) = Op $ tan . f
cos (Op f) = Op $ cos . f
asin (Op f) = Op $ asin . f
atan (Op f) = Op $ atan . f
acos (Op f) = Op $ acos . f
sinh (Op f) = Op $ sinh . f
tanh (Op f) = Op $ tanh . f
cosh (Op f) = Op $ cosh . f
asinh (Op f) = Op $ asinh . f
atanh (Op f) = Op $ atanh . f
acosh (Op f) = Op $ acosh . f
Op f ** Op g = Op $ \a -> f a ** g a
logBase (Op f) (Op g) = Op $ \a -> logBase (f a) (g a)