ref: 6aca60b66493c3f6b6739c5ca4b2b3e3ba8174c9
parent: f0ee74025e2758515028bd91b4ffbcf4110688b4
author: Lennart Augustsson <lennart@augustsson.net>
date: Tue Sep 24 20:38:20 EDT 2024
Add Data.Functor.Congtravariant
--- a/Makefile
+++ b/Makefile
@@ -198,7 +198,7 @@
MCABALBIN=$(MCABAL)/bin
MDIST=dist-mcabal
BASE=base-$(VERSION)
-BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.ST Control.Monad.Zip Data.Array Data.Bifoldable Data.Bifunctor Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Foldable1 Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Compose Data.Functor.Const Data.Functor.Identity Data.Functor.Product Data.Functor.Sum Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Compress System.Directory System.Environment System.Exit System.IO System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.ParserCombinators.ReadP Text.ParserCombinators.ReadPrec Text.Read Text.Read.Lex Text.Show TimeCompat Unsafe.Coerce
+BASEMODULES=Control.Applicative Control.Arrow Control.Category Control.DeepSeq Control.Error Control.Exception Control.Monad Control.Monad.Fail Control.Monad.Fix Control.Monad.ST Control.Monad.Zip Data.Array Data.Bifoldable Data.Bifunctor Data.Bits Data.Bool Data.Bounded Data.ByteString Data.Char Data.Complex Data.Constraint Data.Data Data.Double Data.Dynamic Data.Either Data.Enum Data.Eq Data.Float Data.FloatW Data.Floating Data.Foldable Data.Foldable1 Data.Fractional Data.Function Data.Functor Data.Functor.Classes Data.Functor.Compose Data.Functor.Const Data.Functor.Contravariant Data.Functor.Identity Data.Functor.Product Data.Functor.Sum Data.IOArray Data.IORef Data.Int Data.Integer Data.Integral Data.Ix Data.List Data.List.NonEmpty Data.Maybe Data.Monoid Data.Num Data.Ord Data.Proxy Data.Ratio Data.Real Data.RealFloat Data.RealFrac Data.Records Data.STRef Data.Semigroup Data.String Data.Text Data.Time.Clock Data.Time.Format Data.Traversable Data.Tuple Data.Type.Equality Data.TypeLits Data.Typeable Data.Version Data.Void Data.Word Data.ZipList Debug.Trace Foreign.C.String Foreign.C.Types Foreign.ForeignPtr Foreign.Marshal.Alloc Foreign.Marshal.Array Foreign.Marshal.Utils Foreign.Ptr Foreign.Storable GHC.Stack GHC.Types Numeric Numeric.FormatFloat Numeric.Natural Prelude System.Cmd System.Compress System.Directory System.Environment System.Exit System.IO System.IO.MD5 System.IO.PrintOrRun System.IO.Serialize System.IO.TimeMilli System.IO.Unsafe System.Info System.Process Text.Printf Text.ParserCombinators.ReadP Text.ParserCombinators.ReadPrec Text.Read Text.Read.Lex Text.Show TimeCompat Unsafe.Coerce
$(MCABALBIN)/mhs: bin/mhs
@mkdir -p $(MCABALBIN)
--- a/lib/AllOfLib.hs
+++ b/lib/AllOfLib.hs
@@ -37,6 +37,7 @@
import Data.Functor.Classes
import Data.Functor.Compose
import Data.Functor.Const
+import Data.Functor.Contravariant
import Data.Functor.Identity
import Data.Functor.Product
import Data.Functor.Sum
--- /dev/null
+++ b/lib/Data/Functor/Contravariant.hs
@@ -1,0 +1,383 @@
+{-# 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.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 = () <$ 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)
+-}