{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Contravariant
-- Copyright   :  (C) 2007-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- 'Contravariant' functors, sometimes referred to colloquially as @Cofunctor@,
-- even though the dual of a 'Functor' is just a 'Functor'. As with 'Functor'
-- the definition of 'Contravariant' for a given ADT is unambiguous.
--
-- @since 4.12.0.0
----------------------------------------------------------------------------

module Data.Functor.Contravariant (
  -- * Contravariant Functors
    Contravariant(..)
  , phantom

  -- * Operators
  , (>$<), (>$$<), ($<)

  -- * Predicates
  , Predicate(..)

  -- * Comparisons
  , Comparison(..)
  , defaultComparison

  -- * Equivalence Relations
  , Equivalence(..)
  , defaultEquivalence
  , comparisonEquivalence

  -- * Dual arrows
  , 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(..), All(..))
import Data.Proxy
import GHC.Generics

import Prelude hiding ((.), id)

-- | The class of contravariant functors.
--
-- Whereas in Haskell, one can think of a 'Functor' as containing or producing
-- values, a contravariant functor is a functor that can be thought of as
-- /consuming/ values.
--
-- As an example, consider the type of predicate functions  @a -> Bool@. One
-- such predicate might be @negative x = x < 0@, which
-- classifies integers as to whether they are negative. However, given this
-- predicate, we can re-use it in other situations, providing we have a way to
-- map values /to/ integers. For instance, we can use the @negative@ predicate
-- on a person's bank balance to work out if they are currently overdrawn:
--
-- @
-- newtype Predicate a = Predicate { getPredicate :: a -> Bool }
--
-- instance Contravariant Predicate where
--   contramap :: (a' -> a) -> (Predicate a -> Predicate a')
--   contramap f (Predicate p) = Predicate (p . f)
--                                          |   `- First, map the input...
--                                          `----- then apply the predicate.
--
-- overdrawn :: Predicate Person
-- overdrawn = contramap personBankBalance negative
-- @
--
-- Any instance should be subject to the following laws:
--
-- [Identity]    @'contramap' 'id'      = 'id'@
-- [Composition] @'contramap' (g . f) = 'contramap' f . 'contramap' g@
--
-- Note, that the second law follows from the free theorem of the type of
-- 'contramap' and the first law, so you need only check that the former
-- condition holds.

class Contravariant f where
  contramap :: (a' -> a) -> (f a -> f a')

  -- | Replace all locations in the output with the same value.
  -- The default definition is @'contramap' . 'const'@, but this may be
  -- overridden with a more efficient version.
  (>$) :: b -> f b -> f a
  (>$) = (a -> b) -> f b -> f a
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap ((a -> b) -> f b -> f a) -> (b -> a -> b) -> b -> f b -> f a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a -> b
forall a b. a -> b -> a
const

-- | If @f@ is both 'Functor' and 'Contravariant' then by the time you factor
-- in the laws of each of those classes, it can't actually use its argument in
-- any meaningful capacity.
--
-- This method is surprisingly useful. Where both instances exist and are
-- lawful we have the following laws:
--
-- @
-- 'fmap'      f ≡ 'phantom'
-- 'contramap' f ≡ 'phantom'
-- @
phantom :: (Functor f, Contravariant f) => f a -> f b
phantom :: forall (f :: * -> *) a b.
(Functor f, Contravariant f) =>
f a -> f b
phantom f a
x = () () -> f a -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
x f () -> () -> f b
forall (f :: * -> *) b a. Contravariant f => f b -> b -> f a
$< ()

infixl 4 >$, $<, >$<, >$$<

-- | This is '>$' with its arguments flipped.
($<) :: Contravariant f => f b -> b -> f a
$< :: forall (f :: * -> *) b a. Contravariant f => f b -> b -> f a
($<) = (b -> f b -> f a) -> f b -> b -> f a
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> f b -> f a
forall (f :: * -> *) b a. Contravariant f => b -> f b -> f a
(>$)

-- | This is an infix alias for 'contramap'.
(>$<) :: Contravariant f => (a -> b) -> (f b -> f a)
>$< :: forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
(>$<) = (a -> b) -> f b -> f a
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap

-- | This is an infix version of 'contramap' with the arguments flipped.
(>$$<) :: Contravariant f => f b -> (a -> b) -> f a
>$$< :: forall (f :: * -> *) b a. Contravariant f => f b -> (a -> b) -> f a
(>$$<) = ((a -> b) -> f b -> f a) -> f b -> (a -> b) -> f a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> f b -> f a
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap

deriving newtype instance Contravariant f => Contravariant (Alt f)
deriving newtype instance Contravariant f => Contravariant (Rec1 f)
deriving newtype instance Contravariant f => Contravariant (M1 i c f)

instance Contravariant V1 where
  contramap :: (a' -> a) -> (V1 a -> V1 a')
  contramap :: forall a' a. (a' -> a) -> V1 a -> V1 a'
contramap a' -> a
_ V1 a
x = case V1 a
x of

instance Contravariant U1 where
  contramap :: (a' -> a) -> (U1 a -> U1 a')
  contramap :: forall a' a. (a' -> a) -> U1 a -> U1 a'
contramap a' -> a
_ U1 a
_ = U1 a'
forall k (p :: k). U1 p
U1

instance Contravariant (K1 i c) where
  contramap :: (a' -> a) -> (K1 i c a -> K1 i c a')
  contramap :: forall a' a. (a' -> a) -> K1 i c a -> K1 i c a'
contramap a' -> a
_ (K1 c
c) = c -> K1 i c a'
forall k i c (p :: k). c -> K1 i c p
K1 c
c

instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where
  contramap :: (a' -> a) -> ((f :*: g) a -> (f :*: g) a')
  contramap :: forall a' a. (a' -> a) -> (:*:) f g a -> (:*:) f g a'
contramap a' -> a
f (f a
xs :*: g a
ys) = (a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f f a
xs f a' -> g a' -> (:*:) f g a'
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: (a' -> a) -> g a -> g a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f g a
ys

instance (Functor f, Contravariant g) => Contravariant (f :.: g) where
  contramap :: (a' -> a) -> ((f :.: g) a -> (f :.: g) a')
  contramap :: forall a' a. (a' -> a) -> (:.:) f g a -> (:.:) f g a'
contramap a' -> a
f (Comp1 f (g a)
fg) = f (g a') -> (:.:) f g a'
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 ((g a -> g a') -> f (g a) -> f (g a')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a' -> a) -> g a -> g a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f) f (g a)
fg)

instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where
  contramap :: (a' -> a) -> ((f :+: g) a -> (f :+: g) a')
  contramap :: forall a' a. (a' -> a) -> (:+:) f g a -> (:+:) f g a'
contramap a' -> a
f (L1 f a
xs) = f a' -> (:+:) f g a'
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 ((a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f f a
xs)
  contramap a' -> a
f (R1 g a
ys) = g a' -> (:+:) f g a'
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 ((a' -> a) -> g a -> g a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f g a
ys)

instance (Contravariant f, Contravariant g) => Contravariant (Sum f g) where
  contramap :: (a' -> a) -> (Sum f g a -> Sum f g a')
  contramap :: forall a' a. (a' -> a) -> Sum f g a -> Sum f g a'
contramap a' -> a
f (InL f a
xs) = f a' -> Sum f g a'
forall {k} (f :: k -> *) (g :: k -> *) (a :: k). f a -> Sum f g a
InL ((a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f f a
xs)
  contramap a' -> a
f (InR g a
ys) = g a' -> Sum f g a'
forall {k} (f :: k -> *) (g :: k -> *) (a :: k). g a -> Sum f g a
InR ((a' -> a) -> g a -> g a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f g a
ys)

instance (Contravariant f, Contravariant g)
      => Contravariant (Product f g) where
  contramap :: (a' -> a) -> (Product f g a -> Product f g a')
  contramap :: forall a' a. (a' -> a) -> Product f g a -> Product f g a'
contramap a' -> a
f (Pair f a
a g a
b) = f a' -> g a' -> Product f g a'
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair ((a' -> a) -> f a -> f a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f f a
a) ((a' -> a) -> g a -> g a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f g a
b)

instance Contravariant (Const a) where
  contramap :: (b' -> b) -> (Const a b -> Const a b')
  contramap :: forall a' a. (a' -> a) -> Const a a -> Const a a'
contramap b' -> b
_ (Const a
a) = a -> Const a b'
forall {k} a (b :: k). a -> Const a b
Const a
a

instance (Functor f, Contravariant g) => Contravariant (Compose f g) where
  contramap :: (a' -> a) -> (Compose f g a -> Compose f g a')
  contramap :: forall a' a. (a' -> a) -> Compose f g a -> Compose f g a'
contramap a' -> a
f (Compose f (g a)
fga) = f (g a') -> Compose f g a'
forall {k} {k} (f :: k -> *) (g :: k -> k) (a :: k).
f (g a) -> Compose f g a
Compose ((g a -> g a') -> f (g a) -> f (g a')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a' -> a) -> g a -> g a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a' -> a
f) f (g a)
fga)

instance Contravariant Proxy where
  contramap :: (a' -> a) -> (Proxy a -> Proxy a')
  contramap :: forall a' a. (a' -> a) -> Proxy a -> Proxy a'
contramap a' -> a
_ Proxy a
_ = Proxy a'
forall {k} (t :: k). Proxy t
Proxy

newtype Predicate a = Predicate { forall a. Predicate a -> a -> Bool
getPredicate :: a -> Bool }
  deriving
    ( -- | @('<>')@ on predicates uses logical conjunction @('&&')@ on
      -- the results. Without newtypes this equals @'liftA2' (&&)@.
      --
      -- @
      -- (<>) :: Predicate a -> Predicate a -> Predicate a
      -- Predicate pred <> Predicate pred' = Predicate \a ->
      --   pred a && pred' a
      -- @
      NonEmpty (Predicate a) -> Predicate a
Predicate a -> Predicate a -> Predicate a
(Predicate a -> Predicate a -> Predicate a)
-> (NonEmpty (Predicate a) -> Predicate a)
-> (forall b. Integral b => b -> Predicate a -> Predicate a)
-> Semigroup (Predicate a)
forall b. Integral b => b -> Predicate a -> Predicate a
forall a. NonEmpty (Predicate a) -> Predicate a
forall a. Predicate a -> Predicate a -> Predicate a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Predicate a -> Predicate a
stimes :: forall b. Integral b => b -> Predicate a -> Predicate a
$cstimes :: forall a b. Integral b => b -> Predicate a -> Predicate a
sconcat :: NonEmpty (Predicate a) -> Predicate a
$csconcat :: forall a. NonEmpty (Predicate a) -> Predicate a
<> :: Predicate a -> Predicate a -> Predicate a
$c<> :: forall a. Predicate a -> Predicate a -> Predicate a
Semigroup
    , -- | @'mempty'@ on predicates always returns @True@. Without
      -- newtypes this equals @'pure' True@.
      --
      -- @
      -- mempty :: Predicate a
      -- mempty = \_ -> True
      -- @
      Semigroup (Predicate a)
Predicate a
Semigroup (Predicate a)
-> Predicate a
-> (Predicate a -> Predicate a -> Predicate a)
-> ([Predicate a] -> Predicate a)
-> Monoid (Predicate a)
[Predicate a] -> Predicate a
Predicate a -> Predicate a -> Predicate a
forall a. Semigroup (Predicate a)
forall a. Predicate a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Predicate a] -> Predicate a
forall a. Predicate a -> Predicate a -> Predicate a
mconcat :: [Predicate a] -> Predicate a
$cmconcat :: forall a. [Predicate a] -> Predicate a
mappend :: Predicate a -> Predicate a -> Predicate a
$cmappend :: forall a. Predicate a -> Predicate a -> Predicate a
mempty :: Predicate a
$cmempty :: forall a. Predicate a
Monoid
    )
  via a -> All

  deriving
    ( -- | A 'Predicate' is a 'Contravariant' 'Functor', because
      -- 'contramap' can apply its function argument to the input of
      -- the predicate.
      --
      -- Without newtypes @'contramap' f@ equals precomposing with @f@
      -- (= @(. f)@).
      --
      -- @
      -- contramap :: (a' -> a) -> (Predicate a -> Predicate a')
      -- contramap f (Predicate g) = Predicate (g . f)
      -- @
      (forall a' a. (a' -> a) -> Predicate a -> Predicate a')
-> (forall b a. b -> Predicate b -> Predicate a)
-> Contravariant Predicate
forall b a. b -> Predicate b -> Predicate a
forall a' a. (a' -> a) -> Predicate a -> Predicate a'
forall (f :: * -> *).
(forall a' a. (a' -> a) -> f a -> f a')
-> (forall b a. b -> f b -> f a) -> Contravariant f
>$ :: forall b a. b -> Predicate b -> Predicate a
$c>$ :: forall b a. b -> Predicate b -> Predicate a
contramap :: forall a' a. (a' -> a) -> Predicate a -> Predicate a'
$ccontramap :: forall a' a. (a' -> a) -> Predicate a -> Predicate a'
Contravariant
    )
  via Op Bool

-- | Defines a total ordering on a type as per 'compare'.
--
-- This condition is not checked by the types. You must ensure that the
-- supplied values are valid total orderings yourself.
newtype Comparison a = Comparison { forall a. Comparison a -> a -> a -> Ordering
getComparison :: a -> a -> Ordering }
  deriving
  newtype
    ( -- | @('<>')@ on comparisons combines results with @('<>')
      -- \@Ordering@. Without newtypes this equals @'liftA2' ('liftA2'
      -- ('<>'))@.
      --
      -- @
      -- (<>) :: Comparison a -> Comparison a -> Comparison a
      -- Comparison cmp <> Comparison cmp' = Comparison \a a' ->
      --   cmp a a' <> cmp a a'
      -- @
      NonEmpty (Comparison a) -> Comparison a
Comparison a -> Comparison a -> Comparison a
(Comparison a -> Comparison a -> Comparison a)
-> (NonEmpty (Comparison a) -> Comparison a)
-> (forall b. Integral b => b -> Comparison a -> Comparison a)
-> Semigroup (Comparison a)
forall b. Integral b => b -> Comparison a -> Comparison a
forall a. NonEmpty (Comparison a) -> Comparison a
forall a. Comparison a -> Comparison a -> Comparison a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Comparison a -> Comparison a
stimes :: forall b. Integral b => b -> Comparison a -> Comparison a
$cstimes :: forall a b. Integral b => b -> Comparison a -> Comparison a
sconcat :: NonEmpty (Comparison a) -> Comparison a
$csconcat :: forall a. NonEmpty (Comparison a) -> Comparison a
<> :: Comparison a -> Comparison a -> Comparison a
$c<> :: forall a. Comparison a -> Comparison a -> Comparison a
Semigroup
    , -- | @'mempty'@ on comparisons always returns @EQ@. Without
      -- newtypes this equals @'pure' ('pure' EQ)@.
      --
      -- @
      -- mempty :: Comparison a
      -- mempty = Comparison \_ _ -> EQ
      -- @
      Semigroup (Comparison a)
Comparison a
Semigroup (Comparison a)
-> Comparison a
-> (Comparison a -> Comparison a -> Comparison a)
-> ([Comparison a] -> Comparison a)
-> Monoid (Comparison a)
[Comparison a] -> Comparison a
Comparison a -> Comparison a -> Comparison a
forall a. Semigroup (Comparison a)
forall a. Comparison a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Comparison a] -> Comparison a
forall a. Comparison a -> Comparison a -> Comparison a
mconcat :: [Comparison a] -> Comparison a
$cmconcat :: forall a. [Comparison a] -> Comparison a
mappend :: Comparison a -> Comparison a -> Comparison a
$cmappend :: forall a. Comparison a -> Comparison a -> Comparison a
mempty :: Comparison a
$cmempty :: forall a. Comparison a
Monoid
    )

-- | A 'Comparison' is a 'Contravariant' 'Functor', because 'contramap' can
-- apply its function argument to each input of the comparison function.
instance Contravariant Comparison where
  contramap :: (a' -> a) -> (Comparison a -> Comparison a')
  contramap :: forall a' a. (a' -> a) -> Comparison a -> Comparison a'
contramap a' -> a
f (Comparison a -> a -> Ordering
g) = (a' -> a' -> Ordering) -> Comparison a'
forall a. (a -> a -> Ordering) -> Comparison a
Comparison ((a -> a -> Ordering) -> (a' -> a) -> a' -> a' -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on a -> a -> Ordering
g a' -> a
f)

-- | Compare using 'compare'.
defaultComparison :: Ord a => Comparison a
defaultComparison :: forall a. Ord a => Comparison a
defaultComparison = (a -> a -> Ordering) -> Comparison a
forall a. (a -> a -> Ordering) -> Comparison a
Comparison a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

-- | This data type represents an equivalence relation.
--
-- Equivalence relations are expected to satisfy three laws:
--
-- [Reflexivity]:  @'getEquivalence' f a a = True@
-- [Symmetry]:     @'getEquivalence' f a b = 'getEquivalence' f b a@
-- [Transitivity]:
--    If @'getEquivalence' f a b@ and @'getEquivalence' f b c@ are both 'True'
--    then so is @'getEquivalence' f a c@.
--
-- The types alone do not enforce these laws, so you'll have to check them
-- yourself.
newtype Equivalence a = Equivalence { forall a. Equivalence a -> a -> a -> Bool
getEquivalence :: a -> a -> Bool }
  deriving
    ( -- | @('<>')@ on equivalences uses logical conjunction @('&&')@
      -- on the results. Without newtypes this equals @'liftA2'
      -- ('liftA2' (&&))@.
      --
      -- @
      -- (<>) :: Equivalence a -> Equivalence a -> Equivalence a
      -- Equivalence equiv <> Equivalence equiv' = Equivalence \a b ->
      --   equiv a b && equiv a b
      -- @
      NonEmpty (Equivalence a) -> Equivalence a
Equivalence a -> Equivalence a -> Equivalence a
(Equivalence a -> Equivalence a -> Equivalence a)
-> (NonEmpty (Equivalence a) -> Equivalence a)
-> (forall b. Integral b => b -> Equivalence a -> Equivalence a)
-> Semigroup (Equivalence a)
forall b. Integral b => b -> Equivalence a -> Equivalence a
forall a. NonEmpty (Equivalence a) -> Equivalence a
forall a. Equivalence a -> Equivalence a -> Equivalence a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Equivalence a -> Equivalence a
stimes :: forall b. Integral b => b -> Equivalence a -> Equivalence a
$cstimes :: forall a b. Integral b => b -> Equivalence a -> Equivalence a
sconcat :: NonEmpty (Equivalence a) -> Equivalence a
$csconcat :: forall a. NonEmpty (Equivalence a) -> Equivalence a
<> :: Equivalence a -> Equivalence a -> Equivalence a
$c<> :: forall a. Equivalence a -> Equivalence a -> Equivalence a
Semigroup
    , -- | @'mempty'@ on equivalences always returns @True@. Without
      -- newtypes this equals @'pure' ('pure' True)@.
      --
      -- @
      -- mempty :: Equivalence a
      -- mempty = Equivalence \_ _ -> True
      -- @
      Semigroup (Equivalence a)
Equivalence a
Semigroup (Equivalence a)
-> Equivalence a
-> (Equivalence a -> Equivalence a -> Equivalence a)
-> ([Equivalence a] -> Equivalence a)
-> Monoid (Equivalence a)
[Equivalence a] -> Equivalence a
Equivalence a -> Equivalence a -> Equivalence a
forall a. Semigroup (Equivalence a)
forall a. Equivalence a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Equivalence a] -> Equivalence a
forall a. Equivalence a -> Equivalence a -> Equivalence a
mconcat :: [Equivalence a] -> Equivalence a
$cmconcat :: forall a. [Equivalence a] -> Equivalence a
mappend :: Equivalence a -> Equivalence a -> Equivalence a
$cmappend :: forall a. Equivalence a -> Equivalence a -> Equivalence a
mempty :: Equivalence a
$cmempty :: forall a. Equivalence a
Monoid
    )
  via a -> a -> All

-- | Equivalence relations are 'Contravariant', because you can
-- apply the contramapped function to each input to the equivalence
-- relation.
instance Contravariant Equivalence where
  contramap :: (a' -> a) -> (Equivalence a -> Equivalence a')
  contramap :: forall a' a. (a' -> a) -> Equivalence a -> Equivalence a'
contramap a' -> a
f (Equivalence a -> a -> Bool
g) = (a' -> a' -> Bool) -> Equivalence a'
forall a. (a -> a -> Bool) -> Equivalence a
Equivalence ((a -> a -> Bool) -> (a' -> a) -> a' -> a' -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on a -> a -> Bool
g a' -> a
f)

-- | Check for equivalence with '=='.
--
-- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.
defaultEquivalence :: Eq a => Equivalence a
defaultEquivalence :: forall a. Eq a => Equivalence a
defaultEquivalence = (a -> a -> Bool) -> Equivalence a
forall a. (a -> a -> Bool) -> Equivalence a
Equivalence a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

comparisonEquivalence :: Comparison a -> Equivalence a
comparisonEquivalence :: forall a. Comparison a -> Equivalence a
comparisonEquivalence (Comparison a -> a -> Ordering
p) = (a -> a -> Bool) -> Equivalence a
forall a. (a -> a -> Bool) -> Equivalence a
Equivalence ((a -> a -> Bool) -> Equivalence a)
-> (a -> a -> Bool) -> Equivalence a
forall a b. (a -> b) -> a -> b
$ \a
a a
b -> a -> a -> Ordering
p a
a a
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

-- | Dual function arrows.
newtype Op a b = Op { forall a b. Op a b -> b -> a
getOp :: b -> a }
  deriving
  newtype
    ( -- | @('<>') \@(Op a b)@ without newtypes is @('<>') \@(b->a)@ =
      -- @liftA2 ('<>')@. This lifts the 'Semigroup' operation
      -- @('<>')@ over the output of @a@.
      --
      -- @
      -- (<>) :: Op a b -> Op a b -> Op a b
      -- Op f <> Op g = Op \a -> f a <> g a
      -- @
      NonEmpty (Op a b) -> Op a b
Op a b -> Op a b -> Op a b
(Op a b -> Op a b -> Op a b)
-> (NonEmpty (Op a b) -> Op a b)
-> (forall b. Integral b => b -> Op a b -> Op a b)
-> Semigroup (Op a b)
forall b. Integral b => b -> Op a b -> Op a b
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Semigroup a => NonEmpty (Op a b) -> Op a b
forall a b. Semigroup a => Op a b -> Op a b -> Op a b
forall a b b. (Semigroup a, Integral b) => b -> Op a b -> Op a b
stimes :: forall b. Integral b => b -> Op a b -> Op a b
$cstimes :: forall a b b. (Semigroup a, Integral b) => b -> Op a b -> Op a b
sconcat :: NonEmpty (Op a b) -> Op a b
$csconcat :: forall a b. Semigroup a => NonEmpty (Op a b) -> Op a b
<> :: Op a b -> Op a b -> Op a b
$c<> :: forall a b. Semigroup a => Op a b -> Op a b -> Op a b
Semigroup
    , -- | @'mempty' \@(Op a b)@ without newtypes is @mempty \@(b->a)@
      -- = @\_ -> mempty@.
      --
      -- @
      -- mempty :: Op a b
      -- mempty = Op \_ -> mempty
      -- @
      Semigroup (Op a b)
Op a b
Semigroup (Op a b)
-> Op a b
-> (Op a b -> Op a b -> Op a b)
-> ([Op a b] -> Op a b)
-> Monoid (Op a b)
[Op a b] -> Op a b
Op a b -> Op a b -> Op a b
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {a} {b}. Monoid a => Semigroup (Op a b)
forall a b. Monoid a => Op a b
forall a b. Monoid a => [Op a b] -> Op a b
forall a b. Monoid a => Op a b -> Op a b -> Op a b
mconcat :: [Op a b] -> Op a b
$cmconcat :: forall a b. Monoid a => [Op a b] -> Op a b
mappend :: Op a b -> Op a b -> Op a b
$cmappend :: forall a b. Monoid a => Op a b -> Op a b -> Op a b
mempty :: Op a b
$cmempty :: forall a b. Monoid a => Op a b
Monoid
    )

instance Category Op where
  id :: Op a a
  id :: forall a. Op a a
id = (a -> a) -> Op a a
forall a b. (b -> a) -> Op a b
Op a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id

  (.) :: Op b c -> Op a b -> Op a c
  Op c -> b
f . :: forall b c a. Op b c -> Op a b -> Op a c
. Op b -> a
g = (c -> a) -> Op a c
forall a b. (b -> a) -> Op a b
Op (b -> a
g (b -> a) -> (c -> b) -> c -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. c -> b
f)

instance Contravariant (Op a) where
  contramap :: (b' -> b) -> (Op a b -> Op a b')
  contramap :: forall a' a. (a' -> a) -> Op a a -> Op a a'
contramap b' -> b
f Op a b
g = (b' -> a) -> Op a b'
forall a b. (b -> a) -> Op a b
Op (Op a b -> b -> a
forall a b. Op a b -> b -> a
getOp Op a b
g (b -> a) -> (b' -> b) -> b' -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b' -> b
f)

instance Num a => Num (Op a b) where
  Op b -> a
f + :: Op a b -> Op a b -> Op a b
+ Op b -> a
g = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ \b
a -> b -> a
f b
a a -> a -> a
forall a. Num a => a -> a -> a
+ b -> a
g b
a
  Op b -> a
f * :: Op a b -> Op a b -> Op a b
* Op b -> a
g = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ \b
a -> b -> a
f b
a a -> a -> a
forall a. Num a => a -> a -> a
* b -> a
g b
a
  Op b -> a
f - :: Op a b -> Op a b -> Op a b
- Op b -> a
g = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ \b
a -> b -> a
f b
a a -> a -> a
forall a. Num a => a -> a -> a
- b -> a
g b
a
  abs :: Op a b -> Op a b
abs (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Num a => a -> a
abs (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  signum :: Op a b -> Op a b
signum (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Num a => a -> a
signum (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  fromInteger :: Integer -> Op a b
fromInteger = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (Integer -> b -> a) -> Integer -> Op a b
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> (Integer -> a) -> Integer -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger

instance Fractional a => Fractional (Op a b) where
  Op b -> a
f / :: Op a b -> Op a b -> Op a b
/ Op b -> a
g = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ \b
a -> b -> a
f b
a a -> a -> a
forall a. Fractional a => a -> a -> a
/ b -> a
g b
a
  recip :: Op a b -> Op a b
recip (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Fractional a => a -> a
recip (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  fromRational :: Rational -> Op a b
fromRational = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (Rational -> b -> a) -> Rational -> Op a b
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b -> a
forall a b. a -> b -> a
const (a -> b -> a) -> (Rational -> a) -> Rational -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Rational -> a
forall a. Fractional a => Rational -> a
fromRational

instance Floating a => Floating (Op a b) where
  pi :: Op a b
pi = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> b -> a
forall a b. a -> b -> a
const a
forall a. Floating a => a
pi
  exp :: Op a b -> Op a b
exp (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
exp (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  sqrt :: Op a b -> Op a b
sqrt (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
sqrt (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  log :: Op a b -> Op a b
log (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
log (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  sin :: Op a b -> Op a b
sin (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
sin (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  tan :: Op a b -> Op a b
tan (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
tan (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  cos :: Op a b -> Op a b
cos (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
cos (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  asin :: Op a b -> Op a b
asin (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
asin (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  atan :: Op a b -> Op a b
atan (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
atan (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  acos :: Op a b -> Op a b
acos (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
acos (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  sinh :: Op a b -> Op a b
sinh (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
sinh (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  tanh :: Op a b -> Op a b
tanh (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
tanh (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  cosh :: Op a b -> Op a b
cosh (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
cosh (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  asinh :: Op a b -> Op a b
asinh (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
asinh (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  atanh :: Op a b -> Op a b
atanh (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
atanh (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  acosh :: Op a b -> Op a b
acosh (Op b -> a
f) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Floating a => a -> a
acosh (a -> a) -> (b -> a) -> b -> a
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> a
f
  Op b -> a
f ** :: Op a b -> Op a b -> Op a b
** Op b -> a
g = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ \b
a -> b -> a
f b
a a -> a -> a
forall a. Floating a => a -> a -> a
** b -> a
g b
a
  logBase :: Op a b -> Op a b -> Op a b
logBase (Op b -> a
f) (Op b -> a
g) = (b -> a) -> Op a b
forall a b. (b -> a) -> Op a b
Op ((b -> a) -> Op a b) -> (b -> a) -> Op a b
forall a b. (a -> b) -> a -> b
$ \b
a -> a -> a -> a
forall a. Floating a => a -> a -> a
logBase (b -> a
f b
a) (b -> a
g b
a)