Commit 55e35c0b authored by Icelandjack's avatar Icelandjack Committed by Marge Bot

Predicate, Equivalence derive via `.. -> a -> All'

parent 266310c3
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
......@@ -53,11 +56,11 @@ import Data.Functor.Product
import Data.Functor.Sum
import Data.Functor.Compose
import Data.Monoid (Alt(..))
import Data.Monoid (Alt(..), All(..))
import Data.Proxy
import GHC.Generics
import Prelude hiding ((.),id)
import Prelude hiding ((.), id)
-- | The class of contravariant functors.
--
......@@ -76,6 +79,7 @@ import Prelude hiding ((.),id)
-- 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.
......@@ -86,7 +90,7 @@ import Prelude hiding ((.),id)
--
-- Any instance should be subject to the following laws:
--
-- [Identity] @'contramap' 'id' = 'id'@
-- [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
......@@ -94,7 +98,7 @@ import Prelude hiding ((.),id)
-- condition holds.
class Contravariant f where
contramap :: (a -> b) -> f b -> f a
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
......@@ -110,7 +114,7 @@ class Contravariant f where
-- lawful we have the following laws:
--
-- @
-- 'fmap' f ≡ 'phantom'
-- 'fmap' f ≡ 'phantom'
-- 'contramap' f ≡ 'phantom'
-- @
phantom :: (Functor f, Contravariant f) => f a -> f b
......@@ -123,79 +127,134 @@ infixl 4 >$, $<, >$<, >$$<
($<) = flip (>$)
-- | This is an infix alias for 'contramap'.
(>$<) :: Contravariant f => (a -> b) -> f b -> f a
(>$<) :: 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 instance Contravariant f => Contravariant (Alt f)
deriving instance Contravariant f => Contravariant (Rec1 f)
deriving instance Contravariant f => Contravariant (M1 i c f)
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 f (Pair a b) = Pair (contramap f a) (contramap f b)
=> 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 }
-- | A 'Predicate' is a 'Contravariant' 'Functor', because 'contramap' can
-- apply its function argument to the input of the predicate.
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
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 instance Semigroup (Comparison a)
deriving instance Monoid (Comparison a)
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 f g = Comparison $ on (getComparison g) f
contramap :: (a' -> a) -> (Comparison a -> Comparison a')
contramap f (Comparison g) = Comparison (on g f)
-- | Compare using 'compare'.
defaultComparison :: Ord a => Comparison a
......@@ -214,18 +273,34 @@ defaultComparison = Comparison compare
-- 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 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)
contramap :: (a' -> a) -> (Equivalence a -> Equivalence a')
contramap f (Equivalence g) = Equivalence (on g f)
-- | Check for equivalence with '=='.
--
......@@ -238,15 +313,36 @@ comparisonEquivalence (Comparison p) = Equivalence $ \a b -> p a b == EQ
-- | Dual function arrows.
newtype Op a b = Op { getOp :: b -> a }
deriving instance Semigroup a => Semigroup (Op a b)
deriving instance Monoid a => Monoid (Op a b)
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment