content: -----------------------------------------------------------------------------
  -- |
  -- 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 Control.Monad
  import Data.Function (on)
  
  import Data.Functor
  import Data.Functor.Product
  import Data.Functor.Sum
  import Data.Functor.Compose
  
  import Data.Monoid.Internal (Alt(..), All(..))
  import Data.Proxy
  
  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
    (>$) = contramap . 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 x = void x $< ()
  
  infixl 4 >$, $<, >$<, >$$<
  
  -- | This is '>$' with its arguments flipped.
  ($<) :: Contravariant f => f b -> b -> f a
  ($<) = flip (>$)
  
  -- | This is an infix alias for 'contramap'.
  (>$<) :: Contravariant f => (a -> b) -> (f b -> f a)
  (>$<) = contramap
  
  -- | This is an infix version of 'contramap' with the arguments flipped.
  (>$$<) :: Contravariant f => f b -> (a -> b) -> f a
  (>$$<) = flip 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 _ x = case x of
  
  instance Contravariant U1 where
    contramap :: (a' -> a) -> (U1 a -> U1 a')
    contramap _ _ = U1
  
  instance Contravariant (K1 i c) where
    contramap :: (a' -> a) -> (K1 i c a -> K1 i c a')
    contramap _ (K1 c) = K1 c
  
  instance (Contravariant f, Contravariant g) => Contravariant (f :*: g) where
    contramap :: (a' -> a) -> ((f :*: g) a -> (f :*: g) a')
    contramap f (xs :*: ys) = contramap f xs :*: contramap f ys
  
  instance (Functor f, Contravariant g) => Contravariant (f :.: g) where
    contramap :: (a' -> a) -> ((f :.: g) a -> (f :.: g) a')
    contramap f (Comp1 fg) = Comp1 (fmap (contramap f) fg)
  
  instance (Contravariant f, Contravariant g) => Contravariant (f :+: g) where
    contramap :: (a' -> a) -> ((f :+: g) a -> (f :+: g) a')
    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 :: (a' -> a) -> (Sum f g a -> Sum f g a')
    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 :: (a' -> a) -> (Product f g a -> Product f g a')
    contramap f (Pair a b) = Pair (contramap f a) (contramap f b)
  
  instance Contravariant (Const a) where
  --  contramap :: (b' -> b) -> (Const a b -> Const a b')
    contramap _ (Const a) = Const a
  
  instance (Functor f, Contravariant g) => Contravariant (Compose f g) where
  --  contramap :: (a' -> a) -> (Compose f g a -> Compose f g a')
    contramap f (Compose fga) = Compose (fmap (contramap f) fga)
  
  instance Contravariant Proxy where
  --  contramap :: (a' -> a) -> (Proxy a -> Proxy a')
    contramap _ _ = Proxy
  
  {-
  newtype Predicate a = Predicate { 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
        -- @
        Semigroup
      , -- | @'mempty'@ on predicates always returns @True@. Without
        -- newtypes this equals @'pure' True@.
        --
        -- @
        -- mempty :: Predicate a
        -- mempty = \_ -> True
        -- @
        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)
        -- @
        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 { 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'
        -- @
        Semigroup
      , -- | @'mempty'@ on comparisons always returns @EQ@. Without
        -- newtypes this equals @'pure' ('pure' EQ)@.
        --
        -- @
        -- mempty :: Comparison a
        -- mempty = Comparison \_ _ -> EQ
        -- @
        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 f (Comparison g) = Comparison (on g f)
  
  -- | Compare using 'compare'.
  defaultComparison :: Ord a => Comparison a
  defaultComparison = Comparison 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 { 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
        -- @
        Semigroup
      , -- | @'mempty'@ on equivalences always returns @True@. Without
        -- newtypes this equals @'pure' ('pure' True)@.
        --
        -- @
        -- mempty :: Equivalence a
        -- mempty = Equivalence \_ _ -> True
        -- @
        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 f (Equivalence g) = Equivalence (on g f)
  
  -- | Check for equivalence with '=='.
  --
  -- Note: The instances for 'Double' and 'Float' violate reflexivity for @NaN@.
  defaultEquivalence :: Eq a => Equivalence a
  defaultEquivalence = Equivalence (==)
  
  comparisonEquivalence :: Comparison a -> Equivalence a
  comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ
  
  -- | Dual function arrows.
  newtype Op a b = Op { 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
        -- @
        Semigroup
      , -- | @'mempty' \@(Op a b)@ without newtypes is @mempty \@(b->a)@
        -- = @\_ -> mempty@.
        --
        -- @
        -- mempty :: Op a b
        -- mempty = Op \_ -> mempty
        -- @
        Monoid
      )
  
  instance Category Op where
    id :: Op a a
    id = Op id
  
    (.) :: Op b c -> Op a b -> Op a c
    Op f . Op g = Op (g . f)
  
  instance Contravariant (Op a) where
    contramap :: (b' -> b) -> (Op a b -> Op a b')
    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)
  -}
  