(original) (raw)

{-# LANGUAGE EmptyCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-}

module Data.Functor.Contravariant (

[Contravariant](Data.Functor.Contravariant.html#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.Semigroup (Semigroup(..)) 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](#local-6989586621679477650) -> 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](#local-6989586621679477640) 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](#local-6989586621679477706) 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](#local-6989586621679477622) -> f a + g a Op f * Op g = Op $ [a](#local-6989586621679477625) -> f a * g a Op f - Op g = Op $ [a](#local-6989586621679477628) -> 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](#local-6989586621679477616) -> 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](#local-6989586621679477608) -> f a ** g a logBase (Op f) (Op g) = Op $ [a](#local-6989586621679477611) -> logBase (f a) (g a)