invariant-0.3.1: src/Data/Functor/Invariant.hs
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702
#if GHC_GENERICS_OK
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
#endif
#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
{-|
Module: Data.Functor.Invariant
Copyright: (C) 2012-2015 Nicolas Frisby, (C) 2015 Ryan Scott
License: BSD-style (see the file LICENSE)
Maintainer: Ryan Scott
Portability: Portable
Haskell98 invariant functors (also known as exponential functors).
For more information, see Edward Kmett's article \"Rotten Bananas\":
<http://comonad.com/reader/2008/rotten-bananas/>
-}
module Data.Functor.Invariant
( -- * @Invariant@
Invariant(..)
, invmapFunctor
#if GHC_GENERICS_OK
-- ** @GHC.Generics@
-- $ghcgenerics
, genericInvmap
#endif
, WrappedFunctor(..)
, invmapContravariant
, WrappedContravariant(..)
-- * @Invariant2@
, Invariant2(..)
, invmap2Bifunctor
, WrappedBifunctor(..)
, invmap2Profunctor
, WrappedProfunctor(..)
) where
-- base
import qualified Control.Category as Cat
import Control.Arrow hiding (first)
import Control.Applicative as App
import Control.Exception (Handler(..))
import Control.Monad (MonadPlus(..), liftM)
import qualified Control.Monad.ST as Strict (ST)
import qualified Control.Monad.ST.Lazy as Lazy (ST)
#if MIN_VERSION_base(4,4,0)
import Data.Complex (Complex(..))
#endif
import qualified Data.Foldable as F (Foldable(..))
import qualified Data.Functor.Compose as Functor (Compose(..))
import Data.Functor.Identity (Identity)
import Data.Functor.Product as Functor (Product(..))
import Data.Functor.Sum as Functor (Sum(..))
#if __GLASGOW_HASKELL__ < 711
import Data.Ix (Ix)
#endif
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Monoid as Monoid (First(..), Last(..), Product(..), Sum(..))
#if MIN_VERSION_base(4,8,0)
import Data.Monoid (Alt(..))
#endif
import Data.Monoid (Dual(..), Endo(..))
import Data.Proxy (Proxy(..))
import qualified Data.Semigroup as Semigroup (First(..), Last(..), Option(..))
import Data.Semigroup (Min(..), Max(..), Arg(..))
import qualified Data.Traversable as T (Traversable(..))
#if GHC_GENERICS_OK
import GHC.Generics
#endif
import System.Console.GetOpt as GetOpt
import Text.ParserCombinators.ReadP (ReadP)
import Text.ParserCombinators.ReadPrec (ReadPrec)
-- array
import Data.Array (Array)
-- bifunctors
import Data.Bifunctor
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Fix
import Data.Bifunctor.Flip
import Data.Bifunctor.Join
import Data.Bifunctor.Joker
import qualified Data.Bifunctor.Product as Bifunctor
import qualified Data.Bifunctor.Sum as Bifunctor
import Data.Bifunctor.Tannen
import Data.Bifunctor.Wrapped
-- containers
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Sequence (Seq, ViewL, ViewR)
import Data.Tree (Tree)
-- contravariant
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Compose as Contravariant
import Data.Functor.Contravariant.Divisible
-- profunctors
import Data.Profunctor as Pro
import Data.Profunctor.Cayley
import Data.Profunctor.Choice
import Data.Profunctor.Closed
import Data.Profunctor.Composition
import Data.Profunctor.Mapping
import Data.Profunctor.Monad
import Data.Profunctor.Rep
import Data.Profunctor.Ran
import Data.Profunctor.Strong
import Data.Profunctor.Traversing
import Data.Profunctor.Unsafe
-- StateVar
import Data.StateVar (StateVar(..), SettableStateVar(..))
-- stm
import Control.Concurrent.STM (STM)
-- tagged
import Data.Tagged (Tagged(..))
-- transformers
import Control.Applicative.Backwards (Backwards(..))
import Control.Applicative.Lift (Lift(..))
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Error (ErrorT(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import Control.Monad.Trans.List (ListT, mapListT)
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))
import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT, mapWriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT, mapWriterT)
import Data.Functor.Constant (Constant(..))
import Data.Functor.Reverse (Reverse(..))
-- unordered-containers
import Data.HashMap.Lazy (HashMap)
-------------------------------------------------------------------------------
-- The Invariant class
-------------------------------------------------------------------------------
-- | Any @* -> *@ type parametric in the argument permits an instance of
-- @Invariant@.
--
-- Instances should satisfy the following laws:
--
-- > invmap id id = id
-- > invmap f2 f2' . invmap f1 f1' = invmap (f2 . f1) (f1' . f2')
class Invariant f where
invmap :: (a -> b) -> (b -> a) -> f a -> f b
#if GHC_GENERICS_OK
default invmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
invmap = genericInvmap
#endif
-- | Every 'Functor' is also an 'Invariant' functor.
invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b
invmapFunctor = flip $ const fmap
-- | Every 'Contravariant' functor is also an 'Invariant' functor.
invmapContravariant :: Contravariant f => (a -> b) -> (b -> a) -> f a -> f b
invmapContravariant = const contramap
-------------------------------------------------------------------------------
-- Invariant instances
-------------------------------------------------------------------------------
instance Invariant Maybe where invmap = invmapFunctor
instance Invariant [] where invmap = invmapFunctor
instance Invariant IO where invmap = invmapFunctor
instance Invariant (Strict.ST s) where invmap = invmapFunctor
instance Invariant (Lazy.ST s) where invmap = invmapFunctor
instance Invariant ReadP where invmap = invmapFunctor
instance Invariant ReadPrec where invmap = invmapFunctor
instance Invariant ((->) a) where invmap = invmapFunctor
instance Invariant (Either a) where invmap = invmapFunctor
instance Invariant ((,) a) where invmap = invmapFunctor
instance Invariant ((,,) a b) where invmap f _ ~(a, b, x) = (a, b, f x)
instance Invariant ((,,,) a b c) where
invmap f _ ~(a, b, c, x) = (a, b, c, f x)
instance Invariant ((,,,,) a b c d) where
invmap f _ ~(a, b, c, d, x) = (a, b, c, d, f x)
-- | from "Control.Applicative"
instance Invariant (Const a) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Invariant ZipList where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Monad m => Invariant (WrappedMonad m) where invmap = invmapFunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant (App.WrappedArrow arr a) where
invmap f _ (App.WrapArrow x) = App.WrapArrow $ ((arr f) Cat.. x)
-- | from "Control.Arrow"
instance
#if MIN_VERSION_base(4,4,0)
Arrow a
#else
ArrowApply a
#endif
=> Invariant (ArrowMonad a) where
invmap f _ (ArrowMonad m) = ArrowMonad (m >>> arr f)
-- | from "Control.Exception"
instance Invariant Handler where
invmap f _ (Handler h) = Handler (fmap f . h)
#if MIN_VERSION_base(4,4,0)
-- | from "Data.Complex"
instance Invariant Complex where
invmap f _ (r :+ i) = f r :+ f i
#endif
-- | from "Data.Functor.Compose"
instance (Invariant f, Invariant g) => Invariant (Functor.Compose f g) where
invmap f g (Functor.Compose x) =
Functor.Compose (invmap (invmap f g) (invmap g f) x)
-- | from "Data.Functor.Identity"
instance Invariant Identity where
invmap = invmapFunctor
-- | from "Data.Functor.Product"
instance (Invariant f, Invariant g) => Invariant (Functor.Product f g) where
invmap f g (Functor.Pair x y) = Functor.Pair (invmap f g x) (invmap f g y)
-- | from "Data.Functor.Sum"
instance (Invariant f, Invariant g) => Invariant (Functor.Sum f g) where
invmap f g (InL x) = InL (invmap f g x)
invmap f g (InR y) = InR (invmap f g y)
-- | from "Data.List.NonEmpty"
instance Invariant NonEmpty where
invmap = invmapFunctor
-- | from "Data.Monoid"
instance Invariant Dual where
invmap f _ (Dual x) = Dual (f x)
-- | from "Data.Monoid"
instance Invariant Endo where
invmap f g (Endo x) = Endo (f . x . g)
-- | from "Data.Monoid"
instance Invariant Monoid.First where
invmap f g (Monoid.First x) = Monoid.First (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Last where
invmap f g (Monoid.Last x) = Monoid.Last (invmap f g x)
-- | from "Data.Monoid"
instance Invariant Monoid.Product where
invmap f _ (Monoid.Product x) = Monoid.Product (f x)
-- | from "Data.Monoid"
instance Invariant Monoid.Sum where
invmap f _ (Monoid.Sum x) = Monoid.Sum (f x)
#if MIN_VERSION_base(4,8,0)
-- | from "Data.Monoid"
instance Invariant f => Invariant (Alt f) where
invmap f g (Alt x) = Alt (invmap f g x)
#endif
-- | from "Data.Proxy"
instance Invariant Proxy where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Min where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Max where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.First where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.Last where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant Semigroup.Option where
invmap = invmapFunctor
-- | from "Data.Semigroup"
instance Invariant (Arg a) where
invmap = invmapFunctor
-- | from "System.Console.GetOpt"
instance Invariant ArgDescr where
invmap f _ (NoArg a) = NoArg (f a)
invmap f _ (ReqArg g s) = ReqArg (f . g) s
invmap f _ (OptArg g s) = OptArg (f . g) s
-- | from "System.Console.GetOpt"
instance Invariant ArgOrder where
invmap _ _ RequireOrder = RequireOrder
invmap _ _ Permute = Permute
invmap f _ (ReturnInOrder g) = ReturnInOrder (f . g)
-- | from "System.Console.GetOpt"
instance Invariant OptDescr where
invmap f g (GetOpt.Option a b argDescr c) = GetOpt.Option a b (invmap f g argDescr) c
-- | from the @array@ package
instance
#if __GLASGOW_HASKELL__ < 711
Ix i =>
#endif
Invariant (Array i) where
invmap = invmapFunctor
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant g) => Invariant (Biff p f g a) where
invmap f g = Biff . invmap2 id id (invmap f g) (invmap g f) . runBiff
-- | from the @bifunctors@ package
instance Invariant (Clown f a) where
invmap = invmapFunctor
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Fix p) where
invmap f g = In . invmap2 (invmap f g) (invmap g f) f g . out
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Flip p a) where
invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant (Join p) where
invmap f g = Join . invmap2 f g f g . runJoin
-- | from the @bifunctors@ package
instance Invariant g => Invariant (Joker g a) where
invmap f g = Joker . invmap f g . runJoker
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant (Tannen f p a) where
invmap = invmap2 id id
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant (WrappedBifunctor p a) where
invmap = invmap2 id id
-- | from the @containers@ package
instance Invariant IntMap where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant (Map k) where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Seq where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewL where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant ViewR where
invmap = invmapFunctor
-- | from the @containers@ package
instance Invariant Tree where
invmap = invmapFunctor
-- | from the @contravariant@ package
instance Invariant Predicate where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Comparison where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant Equivalence where invmap = invmapContravariant
-- | from the @contravariant@ package
instance Invariant (Op a) where invmap = invmapContravariant
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (Contravariant.Compose f g) where
invmap f g (Contravariant.Compose x) =
Contravariant.Compose $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeCF f g) where
invmap f g (ComposeCF x) = ComposeCF $ invmap (invmap f g) (invmap g f) x
-- | from the @contravariant@ package
instance (Invariant f, Invariant g) => Invariant (ComposeFC f g) where
invmap f g (ComposeFC x) = ComposeFC $ invmap (invmap f g) (invmap g f) x
-- | from the @profunctors@ package
instance Invariant f => Invariant (Star f a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Costar f a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Arrow arr => Invariant (Pro.WrappedArrow arr a) where
invmap f _ (Pro.WrapArrow x) = Pro.WrapArrow $ ((arr f) Cat.. x)
-- | from the @profunctors@ package
instance Invariant (Forget r a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Closure p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Codensity p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Coprep p) where
invmap f g (Coprep h) = Coprep (h . invmap2 g f id id)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Prep p) where
invmap f g (Prep x p) = Prep x (invmap2 id id f g p)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Procompose p q a) where
invmap k k' (Procompose f g) = Procompose (invmap2 id id k k' f) g
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Rift p q a) where
invmap bd db (Rift f) = Rift (f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance Invariant2 q => Invariant (Ran p q a) where
invmap bd db (Ran f) = Ran (invmap2 id id bd db . f)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (Tambara p a) where
invmap = invmap2 id id
-- | from the @profunctors@ package
instance Invariant (Cotambara p a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant (CotambaraSum p a) where
invmap = invmapFunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant (TambaraSum p a) where
invmap = invmap2 id id
-- | from the @StateVar@ package
instance Invariant StateVar where
invmap f g (StateVar ga sa) = StateVar (fmap f ga) (lmap g sa)
-- | from the @StateVar@ package
instance Invariant SettableStateVar where
invmap = invmapContravariant
-- | from the @stm@ package
instance Invariant STM where
invmap = invmapFunctor
-- | from the @tagged@ package
instance Invariant (Tagged s) where
invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant f => Invariant (Backwards f) where
invmap f g (Backwards a) = Backwards (invmap f g a)
-- | from the @transformers@ package
instance Invariant f => Invariant (Lift f) where
invmap f _ (Pure x) = Pure (f x)
invmap f g (Other y) = Other (invmap f g y)
-- | from the @transformers@ package
instance Invariant (ContT r m) where
invmap = invmapFunctor
-- -- | from the @transformers@ package
instance Invariant m => Invariant (ErrorT e m) where
invmap f g = ErrorT . invmap (invmap f g) (invmap g f) . runErrorT
-- | from the @transformers@ package
instance Invariant m => Invariant (ExceptT e m) where
invmap f g = ExceptT . invmap (invmap f g) (invmap g f) . runExceptT
-- | from the @transformers@ package
instance Invariant m => Invariant (IdentityT m) where
invmap f g = mapIdentityT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (ListT m) where
invmap f g = mapListT $ invmap (invmap f g) (invmap g f)
-- | from the @transformers@ package
instance Invariant m => Invariant (MaybeT m) where
invmap f g = mapMaybeT $ invmap (invmap f g) (invmap g f)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.RWST r w s m) where
invmap f g m = Lazy.RWST $ \r s ->
invmap (mapFstTriple f) (mapFstTriple g) $ Lazy.runRWST m r s
where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
mapFstTriple h ~(a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.RWST r w s m) where
invmap f g m = Strict.RWST $ \r s ->
invmap (mapFstTriple f) (mapFstTriple g) $ Strict.runRWST m r s
where mapFstTriple :: (a -> b) -> (a, c, d) -> (b, c, d)
mapFstTriple h (a, s, w) = (h a, s, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (ReaderT r m) where
invmap f g = mapReaderT (invmap f g)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.StateT s m) where
invmap f g m = Lazy.StateT $ \s ->
invmap (mapFstPair f) (mapFstPair g) $ Lazy.runStateT m s
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h ~(a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.StateT s m) where
invmap f g m = Strict.StateT $ \s ->
invmap (mapFstPair f) (mapFstPair g) $ Strict.runStateT m s
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h (a, s) = (h a, s)
-- | from the @transformers@ package
instance Invariant m => Invariant (Lazy.WriterT w m) where
invmap f g = Lazy.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h ~(a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant m => Invariant (Strict.WriterT w m) where
invmap f g = Strict.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
where mapFstPair :: (a -> b) -> (a, c) -> (b, c)
mapFstPair h (a, w) = (h a, w)
-- | from the @transformers@ package
instance Invariant (Constant a) where
invmap = invmapFunctor
-- | from the @transformers@ package
instance Invariant f => Invariant (Reverse f) where
invmap f g (Reverse a) = Reverse (invmap f g a)
-- | from the @unordered-containers@ package
instance Invariant (HashMap k) where
invmap = invmapFunctor
-------------------------------------------------------------------------------
-- WrappedFunctor
-------------------------------------------------------------------------------
-- | Wrap a 'Functor' to be used as a member of 'Invariant'.
newtype WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }
deriving (Eq, Ord, Read, Show)
instance Functor f => Invariant (WrappedFunctor f) where
invmap = invmapFunctor
instance Functor f => Functor (WrappedFunctor f) where
fmap f = WrapFunctor . fmap f . unwrapFunctor
x <$ WrapFunctor f = WrapFunctor (x <$ f)
instance Applicative f => Applicative (WrappedFunctor f) where
pure = WrapFunctor . pure
WrapFunctor f <*> WrapFunctor x = WrapFunctor (f <*> x)
WrapFunctor a *> WrapFunctor b = WrapFunctor (a *> b)
WrapFunctor a <* WrapFunctor b = WrapFunctor (a <* b)
instance Alternative f => Alternative (WrappedFunctor f) where
empty = WrapFunctor empty
WrapFunctor x <|> WrapFunctor y = WrapFunctor (x <|> y)
some = WrapFunctor . some . unwrapFunctor
many = WrapFunctor . many . unwrapFunctor
instance Monad m => Monad (WrappedFunctor m) where
return = WrapFunctor . return
WrapFunctor x >>= f = WrapFunctor (x >>= unwrapFunctor . f)
WrapFunctor a >> WrapFunctor b = WrapFunctor (a >> b)
instance MonadPlus m => MonadPlus (WrappedFunctor m) where
mzero = WrapFunctor mzero
WrapFunctor x `mplus` WrapFunctor y = WrapFunctor (x `mplus` y)
instance F.Foldable f => F.Foldable (WrappedFunctor f) where
fold = F.fold . unwrapFunctor
foldMap f = F.foldMap f . unwrapFunctor
foldr f z = F.foldr f z . unwrapFunctor
foldl f q = F.foldl f q . unwrapFunctor
foldr1 f = F.foldr1 f . unwrapFunctor
foldl1 f = F.foldl1 f . unwrapFunctor
#if MIN_VERSION_base(4,6,0)
foldr' f z = F.foldr' f z . unwrapFunctor
foldl' f q = F.foldl' f q . unwrapFunctor
#endif
#if MIN_VERSION_base(4,8,0)
toList = F.toList . unwrapFunctor
null = F.null . unwrapFunctor
length = F.length . unwrapFunctor
elem x = F.elem x . unwrapFunctor
maximum = F.maximum . unwrapFunctor
minimum = F.minimum . unwrapFunctor
sum = F.sum . unwrapFunctor
product = F.product . unwrapFunctor
#endif
instance T.Traversable f => T.Traversable (WrappedFunctor f) where
traverse f = fmap WrapFunctor . T.traverse f . unwrapFunctor
sequenceA = fmap WrapFunctor . T.sequenceA . unwrapFunctor
mapM f = liftM WrapFunctor . T.mapM f . unwrapFunctor
sequence = liftM WrapFunctor . T.sequence . unwrapFunctor
-------------------------------------------------------------------------------
-- WrappedContravariant
-------------------------------------------------------------------------------
-- | Wrap a 'Contravariant' functor to be used as a member of 'Invariant'.
newtype WrappedContravariant f a = WrapContravariant { unwrapContravariant :: f a }
deriving (Eq, Ord, Read, Show)
instance Contravariant f => Invariant (WrappedContravariant f) where
invmap = invmapContravariant
instance Contravariant f => Contravariant (WrappedContravariant f) where
contramap f = WrapContravariant . contramap f . unwrapContravariant
x >$ WrapContravariant f = WrapContravariant (x >$ f)
instance Divisible f => Divisible (WrappedContravariant f) where
divide f (WrapContravariant l) (WrapContravariant r) =
WrapContravariant $ divide f l r
conquer = WrapContravariant conquer
instance Decidable f => Decidable (WrappedContravariant f) where
lose = WrapContravariant . lose
choose f (WrapContravariant l) (WrapContravariant r) =
WrapContravariant $ choose f l r
-------------------------------------------------------------------------------
-- The Invariant2 class
-------------------------------------------------------------------------------
-- | Any @* -> * -> *@ type parametric in both arguments permits an instance of
-- @Invariant2@.
--
-- Instances should satisfy the following laws:
--
-- > invmap2 id id id id = id
-- > invmap2 f2 f2' g2 g2' . invmap2 f1 f1' g1 g1' =
-- > invmap2 (f2 . f1) (f1' . f2') (g2 . g1) (g1' . g2')
class Invariant2 f where
invmap2 :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d
-- | Every 'Bifunctor' is also an 'Invariant2' functor.
invmap2Bifunctor :: Bifunctor f
=> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Bifunctor f _ g _ = bimap f g
-- | Every 'Profunctor' is also an 'Invariant2' functor.
invmap2Profunctor :: Profunctor f
=> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Profunctor _ f' g _ = dimap f' g
-------------------------------------------------------------------------------
-- Invariant2 instances
-------------------------------------------------------------------------------
instance Invariant2 (->) where invmap2 = invmap2Profunctor
instance Invariant2 Either where invmap2 = invmap2Bifunctor
instance Invariant2 (,) where invmap2 f _ g _ ~(x, y) = (f x, g y)
instance Invariant2 ((,,) a) where invmap2 f _ g _ ~(a, x, y) = (a, f x, g y)
instance Invariant2 ((,,,) a b) where
invmap2 f _ g _ ~(a, b, x, y) = (a, b, f x, g y)
instance Invariant2 ((,,,,) a b c) where
invmap2 f _ g _ ~(a, b, c, x, y) = (a, b, c, f x, g y)
-- | from "Control.Applicative"
instance Invariant2 Const where invmap2 = invmap2Bifunctor
-- | from "Control.Applicative"
instance Arrow arr => Invariant2 (App.WrappedArrow arr) where
invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f'
-- | from "Data.Semigroup"
instance Invariant2 Arg where
invmap2 = invmap2Bifunctor
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant f, Invariant g) => Invariant2 (Biff p f g) where
invmap2 f f' g g' =
Biff . invmap2 (invmap f f') (invmap f' f) (invmap g g') (invmap g' g) . runBiff
-- | from the @bifunctors@ package
instance Invariant f => Invariant2 (Clown f) where
invmap2 f f' _ _ = Clown . invmap f f' . runClown
-- | from the @bifunctors@ package
instance Invariant2 p => Invariant2 (Flip p) where
invmap2 f f' g g' = Flip . invmap2 g g' f f' . runFlip
-- | from the @bifunctors@ package
instance Invariant g => Invariant2 (Joker g) where
invmap2 _ _ g g' = Joker . invmap g g' . runJoker
-- | from the @bifunctors@ package
instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctor.Product f g) where
invmap2 f f' g g' (Bifunctor.Pair x y) =
Bifunctor.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y)
-- | from the @bifunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Bifunctor.Sum p q) where
invmap2 f f' g g' (Bifunctor.L2 l) = Bifunctor.L2 (invmap2 f f' g g' l)
invmap2 f f' g g' (Bifunctor.R2 r) = Bifunctor.R2 (invmap2 f f' g g' r)
-- | from the @bifunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Tannen f p) where
invmap2 f f' g g' =
Tannen . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runTannen
-- | from the @bifunctors@ package
instance Bifunctor p => Invariant2 (WrappedBifunctor p) where
invmap2 = invmap2Bifunctor
-- | from the @contravariant@ package
instance Invariant2 Op where
invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x
-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Star f) where
invmap2 _ ba cd dc (Star afc) = Star $ invmap cd dc . afc . ba
-- | from the @profunctors@ package
instance Invariant f => Invariant2 (Costar f) where
invmap2 ab ba cd _ (Costar fbc) = Costar $ cd . fbc . invmap ba ab
-- | from the @profunctors@ package
instance Arrow arr => Invariant2 (Pro.WrappedArrow arr) where
invmap2 _ f' g _ (Pro.WrapArrow x) = Pro.WrapArrow $ arr g Cat.. x Cat.. arr f'
-- | from the @profunctors@ package
instance Invariant2 (Forget r) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance (Invariant f, Invariant2 p) => Invariant2 (Cayley f p) where
invmap2 f f' g g' =
Cayley . invmap (invmap2 f f' g g') (invmap2 f' f g' g) . runCayley
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Closure p) where
invmap2 f f' g g' (Closure p) = Closure $ invmap2 (f .) (f' .) (g .) (g' .) p
-- | from the @profunctors@ package
instance Invariant2 (Environment p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Codensity p) where
invmap2 ac ca bd db (Codensity f) =
Codensity (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Procompose p q) where
invmap2 l l' r r' (Procompose f g) =
Procompose (invmap2 id id r r' f) (invmap2 l l' id id g)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Rift p q) where
invmap2 ac ca bd db (Rift f) = Rift (invmap2 ac ca id id . f . invmap2 db bd id id)
-- | from the @profunctors@ package
instance (Invariant2 p, Invariant2 q) => Invariant2 (Ran p q) where
invmap2 ac ca bd db (Ran f) = Ran (invmap2 id id bd db . f . invmap2 id id ca ac)
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (Tambara p) where
invmap2 f f' g g' (Tambara p) =
Tambara $ invmap2 (first f) (first f') (first g) (first g') p
-- | from the @profunctors@ package
instance Invariant2 (PastroSum p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeMapping p) where
invmap2 f f' g g' (CofreeMapping p) =
CofreeMapping (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeMapping p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (CofreeTraversing p) where
invmap2 f f' g g' (CofreeTraversing p) =
CofreeTraversing (invmap2 (fmap f) (fmap f') (fmap g) (fmap g') p)
-- | from the @profunctors@ package
instance Invariant2 (FreeTraversing p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Pastro p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (Cotambara p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CopastroSum p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 (CotambaraSum p) where
invmap2 = invmap2Profunctor
-- | from the @profunctors@ package
instance Invariant2 p => Invariant2 (TambaraSum p) where
invmap2 f f' g g' (TambaraSum p) =
TambaraSum (invmap2 (first f) (first f') (first g) (first g') p)
-- | from the @tagged@ package
instance Invariant2 Tagged where
invmap2 = invmap2Bifunctor
-- | from the @transformers@ package
instance Invariant2 Constant where
invmap2 f _ _ _ (Constant x) = Constant (f x)
-------------------------------------------------------------------------------
-- WrappedProfunctor
-------------------------------------------------------------------------------
-- | Wrap a 'Profunctor' to be used as a member of 'Invariant2'.
newtype WrappedProfunctor p a b = WrapProfunctor { unwrapProfunctor :: p a b }
deriving (Eq, Ord, Read, Show)
instance Profunctor p => Invariant2 (WrappedProfunctor p) where
invmap2 = invmap2Profunctor
instance Profunctor p => Invariant (WrappedProfunctor p a) where
invmap = invmap2 id id
instance Profunctor p => Profunctor (WrappedProfunctor p) where
dimap f g = WrapProfunctor . dimap f g . unwrapProfunctor
lmap f = WrapProfunctor . lmap f . unwrapProfunctor
rmap g = WrapProfunctor . rmap g . unwrapProfunctor
WrapProfunctor x .# f = WrapProfunctor (x .# f)
g #. WrapProfunctor x = WrapProfunctor (g #. x)
instance Strong p => Strong (WrappedProfunctor p) where
first' = WrapProfunctor . first' . unwrapProfunctor
second' = WrapProfunctor . second' . unwrapProfunctor
instance Choice p => Choice (WrappedProfunctor p) where
left' = WrapProfunctor . left' . unwrapProfunctor
right' = WrapProfunctor . right' . unwrapProfunctor
instance Costrong p => Costrong (WrappedProfunctor p) where
unfirst = WrapProfunctor . unfirst . unwrapProfunctor
unsecond = WrapProfunctor . unsecond . unwrapProfunctor
instance Cochoice p => Cochoice (WrappedProfunctor p) where
unleft = WrapProfunctor . unleft . unwrapProfunctor
unright = WrapProfunctor . unright . unwrapProfunctor
instance Closed p => Closed (WrappedProfunctor p) where
closed = WrapProfunctor . closed . unwrapProfunctor
instance Traversing p => Traversing (WrappedProfunctor p) where
traverse' = WrapProfunctor . traverse' . unwrapProfunctor
wander f = WrapProfunctor . wander f . unwrapProfunctor
instance Mapping p => Mapping (WrappedProfunctor p) where
map' = WrapProfunctor . map' . unwrapProfunctor
instance ProfunctorFunctor WrappedProfunctor where
promap f = WrapProfunctor . f . unwrapProfunctor
instance ProfunctorMonad WrappedProfunctor where
proreturn = WrapProfunctor
projoin = unwrapProfunctor
instance ProfunctorComonad WrappedProfunctor where
proextract = unwrapProfunctor
produplicate = WrapProfunctor
#if GHC_GENERICS_OK
-------------------------------------------------------------------------------
-- GHC Generics
-------------------------------------------------------------------------------
-- | from "GHC.Generics"
instance Invariant V1 where
-- NSF 25 July 2015: I'd prefer an -XEmptyCase, but Haskell98.
invmap _ _ _ = error "Invariant V1"
-- | from "GHC.Generics"
instance Invariant U1 where invmap _ _ _ = U1
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:+:) l r) where
invmap f g (L1 l) = L1 $ invmap f g l
invmap f g (R1 r) = R1 $ invmap f g r
-- | from "GHC.Generics"
instance (Invariant l, Invariant r) => Invariant ((:*:) l r) where
invmap f g ~(l :*: r) = invmap f g l :*: invmap f g r
-- | from "GHC.Generics"
instance Invariant (K1 i c) where invmap _ _ (K1 c) = K1 c
-- | from "GHC.Generics"
instance Invariant2 (K1 i) where invmap2 f _ _ _ (K1 c) = K1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (M1 i t f) where invmap f g (M1 fp) = M1 $ invmap f g fp
-- | from "GHC.Generics"
instance Invariant Par1 where invmap f _ (Par1 c) = Par1 $ f c
-- | from "GHC.Generics"
instance Invariant f => Invariant (Rec1 f) where invmap f g (Rec1 fp) = Rec1 $ invmap f g fp
-- | from "GHC.Generics"
instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where
invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp
# if __GLASGOW_HASKELL__ >= 800
instance Invariant UAddr where
invmap _ _ (UAddr a) = UAddr a
instance Invariant UChar where
invmap _ _ (UChar c) = UChar c
instance Invariant UDouble where
invmap _ _ (UDouble d) = UDouble d
instance Invariant UFloat where
invmap _ _ (UFloat f) = UFloat f
instance Invariant UInt where
invmap _ _ (UInt i) = UInt i
instance Invariant UWord where
invmap _ _ (UWord w) = UWord w
# endif
{- $ghcgenerics
With GHC 7.2 or later, 'Invariant' instances can be defined easily using GHC
generics like so:
@
{-# LANGUAGE DeriveGeneric, FlexibleContexts #-}
import Data.Functor.Invariant
import GHC.Generics
data T f a = T (f a) deriving Generic1
instance Invariant f => 'Invariant' (T f)
@
Be aware that generic 'Invariant' instances cannot be derived for data types
that have function arguments in which the last type parameter appears in a
position other than the result type (e.g., @data Fun a = Fun (a -> a)@). For
these, you can derive them using the "Data.Functor.Invariant.TH" module.
-}
-- | A generic implementation of 'invmap'.
genericInvmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
genericInvmap f g = to1 . invmap f g . from1
#endif