#define GHC_GENERICS_OK __GLASGOW_HASKELL__ >= 702
#if GHC_GENERICS_OK
#endif
#if __GLASGOW_HASKELL__ >= 706
#endif
module Data.Functor.Invariant
(
Invariant(..)
, invmapFunctor
#if GHC_GENERICS_OK
, genericInvmap
#endif
, WrappedFunctor(..)
, invmapContravariant
, WrappedContravariant(..)
, Invariant2(..)
, invmap2Bifunctor
, WrappedBifunctor(..)
, invmap2Profunctor
, WrappedProfunctor(..)
) where
import qualified Control.Category as Cat
import Control.Arrow
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)
import qualified Data.Foldable as F (Foldable(..))
import Data.Functor.Identity (Identity)
#if __GLASGOW_HASKELL__ < 711
import Data.Ix (Ix)
#endif
import qualified Data.Monoid as Monoid (First(..), Last(..))
#if MIN_VERSION_base(4,8,0)
import Data.Monoid (Alt(..))
#endif
import Data.Monoid (Dual(..), Endo(..))
import Data.Proxy (Proxy(..))
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)
import Data.Array (Array)
import Data.Bifunctor hiding (first)
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Flip
import Data.Bifunctor.Join
import Data.Bifunctor.Joker
import qualified Data.Bifunctor.Product as Bifunctors
import Data.Bifunctor.Tannen
import Data.Bifunctor.Wrapped
import Data.IntMap (IntMap)
import Data.Map (Map)
import Data.Sequence (Seq, ViewL, ViewR)
import Data.Tree (Tree)
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Compose as Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Profunctor as Pro
import Data.Profunctor.Cayley
import Data.Profunctor.Closed
import Data.Profunctor.Codensity
import Data.Profunctor.Composition
import Data.Profunctor.Ran
import Data.Profunctor.Tambara
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Semigroup as Semigroup (First(..), Last(..), Option(..))
import Data.Semigroup (Min(..), Max(..), Arg(..))
import Control.Concurrent.STM (STM)
import Data.Tagged (Tagged(..))
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 qualified Data.Functor.Compose as Transformers (Compose(..))
import Data.Functor.Constant (Constant(..))
import Data.Functor.Product as Transformers (Product(..))
import Data.Functor.Reverse (Reverse(..))
import Data.Functor.Sum as Transformers (Sum(..))
import Data.HashMap.Lazy (HashMap)
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
invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b
invmapFunctor = flip $ const fmap
invmapContravariant :: Contravariant f => (a -> b) -> (b -> a) -> f a -> f b
invmapContravariant = const contramap
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)
instance Invariant (Const a) where invmap = invmapFunctor
instance Invariant ZipList where invmap = invmapFunctor
instance Monad m => Invariant (WrappedMonad m) where invmap = invmapFunctor
instance Arrow arr => Invariant (App.WrappedArrow arr a) where
invmap f _ (App.WrapArrow x) = App.WrapArrow $ ((arr f) Cat.. x)
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
instance Invariant Handler where
invmap f _ (Handler h) = Handler (fmap f . h)
instance Invariant Identity where
invmap = invmapFunctor
instance Invariant Dual where invmap f _ (Dual x) = Dual (f x)
instance Invariant Endo where
invmap f g (Endo x) = Endo (f . x . g)
instance Invariant Monoid.First where
invmap f g (Monoid.First x) = Monoid.First (invmap f g x)
instance Invariant Monoid.Last where
invmap f g (Monoid.Last x) = Monoid.Last (invmap f g x)
#if MIN_VERSION_base(4,8,0)
instance Invariant f => Invariant (Alt f) where
invmap f g (Alt x) = Alt (invmap f g x)
#endif
instance Invariant Proxy where
invmap = invmapFunctor
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
instance Invariant ArgOrder where
invmap _ _ RequireOrder = RequireOrder
invmap _ _ Permute = Permute
invmap f _ (ReturnInOrder g) = ReturnInOrder (f . g)
instance Invariant OptDescr where
invmap f g (GetOpt.Option a b argDescr c) = GetOpt.Option a b (invmap f g argDescr) c
instance
#if __GLASGOW_HASKELL__ < 711
Ix i =>
#endif
Invariant (Array i) where
invmap = invmapFunctor
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
instance Invariant (Clown f a) where
invmap = invmapFunctor
instance Invariant2 p => Invariant (Flip p a) where
invmap = invmap2 id id
instance Invariant2 p => Invariant (Join p) where
invmap f g = Join . invmap2 f g f g . runJoin
instance Invariant g => Invariant (Joker g a) where
invmap = invmap2 id id
instance (Invariant f, Invariant2 p) => Invariant (Tannen f p a) where
invmap = invmap2 id id
instance Bifunctor p => Invariant (WrappedBifunctor p a) where
invmap = invmap2 id id
instance Invariant IntMap where
invmap = invmapFunctor
instance Invariant (Map k) where
invmap = invmapFunctor
instance Invariant Seq where
invmap = invmapFunctor
instance Invariant ViewL where
invmap = invmapFunctor
instance Invariant ViewR where
invmap = invmapFunctor
instance Invariant Tree where
invmap = invmapFunctor
instance Invariant Predicate where invmap = invmapContravariant
instance Invariant Comparison where invmap = invmapContravariant
instance Invariant Equivalence where invmap = invmapContravariant
instance Invariant (Op a) where invmap = invmapContravariant
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
instance (Invariant f, Invariant g) => Invariant (ComposeCF f g) where
invmap f g (ComposeCF x) = ComposeCF $ invmap (invmap f g) (invmap g f) x
instance (Invariant f, Invariant g) => Invariant (ComposeFC f g) where
invmap f g (ComposeFC x) = ComposeFC $ invmap (invmap f g) (invmap g f) x
instance Invariant f => Invariant (Star f a) where
invmap = invmap2 id id
instance Invariant (Costar f a) where
invmap = invmapFunctor
instance Arrow arr => Invariant (Pro.WrappedArrow arr a) where
invmap f _ (Pro.WrapArrow x) = Pro.WrapArrow $ ((arr f) Cat.. x)
instance Invariant (Forget r a) where
invmap = invmapFunctor
instance Invariant2 p => Invariant (Closure p a) where
invmap = invmap2 id id
instance Invariant2 p => Invariant (Codensity p a) where
invmap = invmap2 id id
instance Invariant2 p => Invariant (Procompose p q a) where
invmap k k' (Procompose f g) = Procompose (invmap2 id id k k' f) g
instance Invariant2 p => Invariant (Rift p q a) where
invmap bd db (Rift f) = Rift (f . invmap2 db bd id id)
instance Invariant2 q => Invariant (Ran p q a) where
invmap bd db (Ran f) = Ran (invmap2 id id bd db . f)
instance Invariant2 p => Invariant (Tambara p a) where
invmap = invmap2 id id
instance Invariant2 p => Invariant (Cotambara p a) where
invmap = invmap2 id id
instance Invariant NonEmpty where
invmap = invmapFunctor
instance Invariant Min where
invmap = invmapFunctor
instance Invariant Max where
invmap = invmapFunctor
instance Invariant Semigroup.First where
invmap = invmapFunctor
instance Invariant Semigroup.Last where
invmap = invmapFunctor
instance Invariant Semigroup.Option where
invmap = invmapFunctor
instance Invariant (Arg a) where
invmap = invmapFunctor
instance Invariant STM where
invmap = invmapFunctor
instance Invariant (Tagged s) where
invmap = invmapFunctor
instance Invariant f => Invariant (Backwards f) where
invmap f g (Backwards a) = Backwards (invmap f g a)
instance Invariant f => Invariant (Lift f) where
invmap f _ (Pure x) = Pure (f x)
invmap f g (Other y) = Other (invmap f g y)
instance Invariant (ContT r m) where
invmap = invmapFunctor
instance Invariant m => Invariant (ErrorT e m) where
invmap f g = ErrorT . invmap (invmap f g) (invmap g f) . runErrorT
instance Invariant m => Invariant (ExceptT e m) where
invmap f g = ExceptT . invmap (invmap f g) (invmap g f) . runExceptT
instance Invariant m => Invariant (IdentityT m) where
invmap f g = mapIdentityT (invmap f g)
instance Invariant m => Invariant (ListT m) where
invmap f g = mapListT $ invmap (invmap f g) (invmap g f)
instance Invariant m => Invariant (MaybeT m) where
invmap f g = mapMaybeT $ invmap (invmap f g) (invmap g f)
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 h ~(a, s, w) = (h a, s, w)
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 h (a, s, w) = (h a, s, w)
instance Invariant m => Invariant (ReaderT r m) where
invmap f g = mapReaderT (invmap f g)
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 h ~(a, s) = (h a, s)
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 h (a, s) = (h a, s)
instance Invariant m => Invariant (Lazy.WriterT w m) where
invmap f g = Lazy.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
where mapFstPair h ~(a, w) = (h a, w)
instance Invariant m => Invariant (Strict.WriterT w m) where
invmap f g = Strict.mapWriterT $ invmap (mapFstPair f) (mapFstPair g)
where mapFstPair h (a, w) = (h a, w)
instance (Invariant f, Invariant g) => Invariant (Transformers.Compose f g) where
invmap f g (Transformers.Compose x) =
Transformers.Compose (invmap (invmap f g) (invmap g f) x)
instance Invariant (Constant a) where
invmap = invmapFunctor
instance (Invariant f, Invariant g) => Invariant (Transformers.Product f g) where
invmap f g (Transformers.Pair x y) = Transformers.Pair (invmap f g x) (invmap f g y)
instance Invariant f => Invariant (Reverse f) where
invmap f g (Reverse a) = Reverse (invmap f g a)
instance (Invariant f, Invariant g) => Invariant (Transformers.Sum f g) where
invmap f g (InL x) = InL (invmap f g x)
invmap f g (InR y) = InR (invmap f g y)
instance Invariant (HashMap k) where
invmap = invmapFunctor
newtype WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a }
deriving (Eq, Ord, Read, Show)
instance Functor f => Invariant (WrappedFunctor f) where
invmap f g = WrapFunctor . invmapFunctor f g . unwrapFunctor
instance Functor f => Functor (WrappedFunctor f) where
fmap f = WrapFunctor . fmap f . unwrapFunctor
instance Applicative f => Applicative (WrappedFunctor f) where
pure = WrapFunctor . pure
WrapFunctor f <*> WrapFunctor x = WrapFunctor $ f <*> x
instance Alternative f => Alternative (WrappedFunctor f) where
empty = WrapFunctor empty
WrapFunctor x <|> WrapFunctor y = WrapFunctor $ x <|> y
instance Monad m => Monad (WrappedFunctor m) where
return = WrapFunctor . return
WrapFunctor x >>= f = WrapFunctor $ x >>= unwrapFunctor . f
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
newtype WrappedContravariant f a = WrapContravariant { unwrapContravariant :: f a }
deriving (Eq, Ord, Read, Show)
instance Contravariant f => Invariant (WrappedContravariant f) where
invmap f g = WrapContravariant . invmapContravariant f g . unwrapContravariant
instance Contravariant f => Contravariant (WrappedContravariant f) where
contramap f = WrapContravariant . contramap f . unwrapContravariant
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
class Invariant2 f where
invmap2 :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> f a b -> f c d
invmap2Bifunctor :: Bifunctor f
=> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Bifunctor f _ g _ = bimap f g
invmap2Profunctor :: Profunctor f
=> (a -> c) -> (c -> a)
-> (b -> d) -> (d -> b)
-> f a b -> f c d
invmap2Profunctor _ f' g _ = dimap f' g
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)
instance Invariant2 Const where invmap2 = invmap2Bifunctor
instance Arrow arr => Invariant2 (App.WrappedArrow arr) where
invmap2 _ f' g _ (App.WrapArrow x) = App.WrapArrow $ arr g Cat.. x Cat.. arr f'
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
instance Invariant f => Invariant2 (Clown f) where
invmap2 f f' _ _ = Clown . invmap f f' . runClown
instance Invariant2 p => Invariant2 (Flip p) where
invmap2 f f' g g' = Flip . invmap2 g g' f f' . runFlip
instance Invariant g => Invariant2 (Joker g) where
invmap2 _ _ g g' = Joker . invmap g g' . runJoker
instance (Invariant2 f, Invariant2 g) => Invariant2 (Bifunctors.Product f g) where
invmap2 f f' g g' (Bifunctors.Pair x y) =
Bifunctors.Pair (invmap2 f f' g g' x) (invmap2 f f' g g' y)
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
instance Bifunctor p => Invariant2 (WrappedBifunctor p) where
invmap2 f f' g g' = WrapBifunctor . invmap2Bifunctor f f' g g' . unwrapBifunctor
instance Invariant2 Op where
invmap2 f f' g g' (Op x) = Op $ invmap2 g g' f f' x
instance Invariant f => Invariant2 (Star f) where
invmap2 _ ba cd dc (Star afc) = Star $ invmap cd dc . afc . ba
instance Invariant f => Invariant2 (Costar f) where
invmap2 ab ba cd _ (Costar fbc) = Costar $ cd . fbc . invmap ba ab
instance Arrow arr => Invariant2 (Pro.WrappedArrow arr) where
invmap2 _ f' g _ (Pro.WrapArrow x) = Pro.WrapArrow $ arr g Cat.. x Cat.. arr f'
instance Invariant2 (Forget r) where
invmap2 = invmap2Profunctor
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
instance Invariant2 p => Invariant2 (Closure p) where
invmap2 f f' g g' (Closure p) = Closure $ invmap2 (f .) (f' .) (g .) (g' .) p
instance Invariant2 (Environment p) where
invmap2 _ f' g _ (Environment l m r) = Environment (g . l) m (r . f')
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)
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)
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)
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)
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
instance Invariant2 (Pastro p) where
invmap2 _ f' g _ (Pastro l m r) = Pastro (g . l) m (r . f')
instance Invariant2 p => Invariant2 (Cotambara p) where
invmap2 f f' g g' (Cotambara p) =
Cotambara $ invmap2 (left f) (left f') (left g) (left g') p
instance Invariant2 (Copastro p) where
invmap2 _ f' g _ (Copastro l m r) = Copastro (g . l) m (r . f')
instance Invariant2 Arg where
invmap2 = invmap2Bifunctor
instance Invariant2 Tagged where
invmap2 = invmap2Bifunctor
instance Invariant2 Constant where
invmap2 f _ _ _ (Constant x) = Constant (f x)
newtype WrappedProfunctor p a b = WrapProfunctor { unwrapProfunctor :: p a b }
deriving (Eq, Ord, Read, Show)
instance Profunctor p => Invariant2 (WrappedProfunctor p) where
invmap2 f f' g g' = WrapProfunctor . invmap2Profunctor f f' g g' . unwrapProfunctor
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
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
#if GHC_GENERICS_OK
instance Invariant V1 where
invmap _ _ _ = error "Invariant V1"
instance Invariant U1 where invmap _ _ _ = U1
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
instance (Invariant l, Invariant r) => Invariant ((:*:) l r) where
invmap f g ~(l :*: r) = invmap f g l :*: invmap f g r
instance Invariant (K1 i c) where invmap _ _ (K1 c) = K1 c
instance Invariant2 (K1 i) where invmap2 f _ _ _ (K1 c) = K1 $ f c
instance Invariant f => Invariant (M1 i t f) where invmap f g (M1 fp) = M1 $ invmap f g fp
instance Invariant Par1 where invmap f _ (Par1 c) = Par1 $ f c
instance Invariant f => Invariant (Rec1 f) where invmap f g (Rec1 fp) = Rec1 $ invmap f g fp
instance (Invariant f, Invariant g) => Invariant ((:.:) f g) where
invmap f g (Comp1 fgp) = Comp1 $ invmap (invmap f g) (invmap g f) fgp
genericInvmap :: (Generic1 f, Invariant (Rep1 f)) => (a -> b) -> (b -> a) -> f a -> f b
genericInvmap f g = to1 . invmap f g . from1
#endif