BiId.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- @BiId p s t a b@ — a newtype around @p (s a) (t b)@, with optics and instances
-- for switching the type constructors @p@, @s@, and @t@.
module Data.BiId
  ( -- * BiId data type
    BiId (..),

    -- * Optics
    __Wrapped,
    identityBifunctor,
    identityProfunctor,
    identityProfunctorBifunctor,
    identityBifunctorProfunctor,
    identityRightBifunctor,
    identityRightProfunctor,
    identityRightProfunctorBifunctor,
    identityRightBifunctorProfunctor,
    identityLeftBifunctor,
    identityLeftProfunctor,
    identityLeftProfunctorBifunctor,
    identityLeftBifunctorProfunctor,

    -- * Type aliases
    BiIdIdentity,
    BiIdIdentityLeft,
    BiIdIdentityRight,
    Product,
    Coproduct,
    Exponential,
  )
where

import Control.Applicative (Alternative (empty, (<|>)))
import Control.Comonad (Comonad (..))
import Control.Lens
  ( FoldableWithIndex (..),
    FunctorWithIndex (..),
    Iso,
    Rewrapped,
    TraversableWithIndex (..),
    Wrapped (..),
    iso,
  )
import Control.Monad (MonadPlus (..), join)
import Control.Monad.Cont (MonadCont (..))
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.RWS.Class (MonadRWS)
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.State.Class (MonadState (..))
import Control.Monad.Writer (MonadWriter (..))
import Control.Monad.Zip (MonadZip (..))
import Control.Selective (Selective (..))
import Data.Biapplicative (Biapplicative (..))
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Data (Data)
import Data.Distributive (Distributive (..))
import Data.Functor.Alt (Alt ((<!>)))
import Data.Functor.Apply (Apply ((<.>), liftF2))
import Data.Functor.Bind (Bind ((>>-)))
import Data.Functor.Classes
  ( Eq1 (..),
    Eq2 (..),
    Ord1 (..),
    Ord2 (..),
    Show1 (..),
    Show2 (..),
  )
import Data.Functor.Contravariant (Contravariant (..))
import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))
import Data.Functor.Extend (Extend (..))
import Data.Functor.Identity
import Data.Functor.Plus (Plus (..))
import Data.Profunctor (Profunctor (..))
import Data.Profunctor.Choice (Choice (..), Cochoice (..))
import Data.Profunctor.Closed (Closed (..))
import Data.Profunctor.Strong (Costrong (..), Strong (..))
import Data.Semigroup.Bifoldable (Bifoldable1 (..))
import Data.Semigroup.Bitraversable (Bitraversable1 (..))
import Data.Semigroup.Foldable (Foldable1 (..))
import Data.Semigroup.Traversable (Traversable1 (..))
import GHC.Generics (Generic, Generic1)

-- $setup
-- >>> import Control.Lens (view, over, from)
-- >>> import Data.Functor.Identity (Identity(..), runIdentity)
-- >>> import Data.Semigroup (Sum(..))
-- >>> import Data.Tagged (Tagged(..))

-- |
-- >>> BiId ([1,2,3], Identity True)
-- BiId ([1,2,3],Identity True)
--
-- >>> BiId ([1,2,3], Identity True) == BiId ([1,2,3], Identity True)
-- True
--
-- >>> BiId ([1,2,3], Identity True) == BiId ([4,5], Identity False)
-- False
--
-- >>> compare (BiId ([1], Identity True)) (BiId ([2], Identity False))
-- LT
newtype BiId p s t a b = BiId (p (s a) (t b))
  deriving stock (Eq, Ord, Show, Data, Generic, Generic1)

-- |
-- >>> BiId ([1,2], [True, False]) :: Product [] [] Int Bool
-- BiId ([1,2],[True,False])
type Product s t a b = BiId (,) s t a b

-- |
-- >>> BiId (Left [1,2]) :: Coproduct [] [] Int Bool
-- BiId (Left [1,2])
type Coproduct s t a b = BiId Either s t a b

-- |
-- >>> (\(BiId f) -> f [1,2,3]) (BiId (fmap (+1)) :: Exponential [] [] Int Int)
-- [2,3,4]
type Exponential s t a b = BiId (->) s t a b

type BiIdIdentity p a b = BiId p Identity Identity a b

type BiIdIdentityLeft p t a b = BiId p Identity t a b

type BiIdIdentityRight p s a b = BiId p s Identity a b

-- |
-- >>> view identityBifunctor (BiId (Identity 3, Identity True) :: BiIdIdentity (,) Int Bool)
-- (3,True)
--
-- >>> view (from identityBifunctor) (3, True) :: BiIdIdentity (,) Int Bool
-- BiId (Identity 3,Identity True)
identityBifunctor ::
  (Bifunctor p, Bifunctor p') =>
  Iso
    (BiIdIdentity p a b)
    (BiIdIdentity p' a' b')
    (p a b)
    (p' a' b')
identityBifunctor =
  iso
    (\(BiId x) -> bimap runIdentity runIdentity x)
    (BiId . bimap Identity Identity)
{-# INLINE identityBifunctor #-}
{-# SPECIALIZE identityBifunctor :: Iso (BiIdIdentity (,) a b) (BiIdIdentity (,) a' b') ((,) a b) ((,) a' b') #-}
{-# SPECIALIZE identityBifunctor :: Iso (BiIdIdentity Either a b) (BiIdIdentity Either a' b') (Either a b) (Either a' b') #-}
{-# SPECIALIZE identityBifunctor :: Iso (BiIdIdentity (,) a b) (BiIdIdentity Either a' b') ((,) a b) (Either a' b') #-}
{-# SPECIALIZE identityBifunctor :: Iso (BiIdIdentity Either a b) (BiIdIdentity (,) a' b') (Either a b) ((,) a' b') #-}

-- |
-- >>> view identityProfunctor (BiId (Tagged (Identity True)) :: BiIdIdentity Tagged Int Bool)
-- Tagged True
--
-- >>> view (from identityProfunctor) (Tagged True) :: BiIdIdentity Tagged Int Bool
-- BiId (Tagged (Identity True))
identityProfunctor ::
  (Profunctor p, Profunctor p') =>
  Iso
    (BiIdIdentity p a b)
    (BiIdIdentity p' a' b')
    (p a b)
    (p' a' b')
identityProfunctor =
  iso
    (\(BiId x) -> dimap Identity runIdentity x)
    (BiId . dimap runIdentity Identity)
{-# INLINE identityProfunctor #-}
{-# SPECIALIZE identityProfunctor :: Iso (BiIdIdentity (->) a b) (BiIdIdentity (->) a' b') ((->) a b) ((->) a' b') #-}

-- |
-- >>> view identityProfunctorBifunctor (BiId (Tagged (Identity True)) :: BiIdIdentity Tagged Int Bool) :: Tagged Int Bool
-- Tagged True
identityProfunctorBifunctor ::
  (Profunctor p, Bifunctor p') =>
  Iso
    (BiIdIdentity p a b)
    (BiIdIdentity p' a' b')
    (p a b)
    (p' a' b')
identityProfunctorBifunctor =
  iso
    (\(BiId x) -> dimap Identity runIdentity x)
    (BiId . bimap Identity Identity)
{-# INLINE identityProfunctorBifunctor #-}
{-# SPECIALIZE identityProfunctorBifunctor :: Iso (BiIdIdentity (->) a b) (BiIdIdentity (,) a' b') ((->) a b) ((,) a' b') #-}
{-# SPECIALIZE identityProfunctorBifunctor :: Iso (BiIdIdentity (->) a b) (BiIdIdentity Either a' b') ((->) a b) (Either a' b') #-}

-- |
-- >>> view identityBifunctorProfunctor (BiId (Tagged (Identity True)) :: BiIdIdentity Tagged Int Bool) :: Tagged Int Bool
-- Tagged True
identityBifunctorProfunctor ::
  (Bifunctor p, Profunctor p') =>
  Iso
    (BiIdIdentity p a b)
    (BiIdIdentity p' a' b')
    (p a b)
    (p' a' b')
identityBifunctorProfunctor =
  iso
    (\(BiId x) -> bimap runIdentity runIdentity x)
    (BiId . dimap runIdentity Identity)
{-# INLINE identityBifunctorProfunctor #-}
{-# SPECIALIZE identityBifunctorProfunctor :: Iso (BiIdIdentity (,) a b) (BiIdIdentity (->) a' b') ((,) a b) ((->) a' b') #-}
{-# SPECIALIZE identityBifunctorProfunctor :: Iso (BiIdIdentity Either a b) (BiIdIdentity (->) a' b') (Either a b) ((->) a' b') #-}

-- |
-- >>> view identityRightProfunctor (BiId (Tagged (Identity True)) :: BiIdIdentityRight Tagged [] Int Bool)
-- Tagged True
--
-- >>> view (from identityRightProfunctor) (Tagged True) :: BiIdIdentityRight Tagged [] Int Bool
-- BiId (Tagged (Identity True))
identityRightProfunctor ::
  (Profunctor p, Profunctor p') =>
  Iso
    (BiIdIdentityRight p s a b)
    (BiIdIdentityRight p' s' a' b')
    (p (s a) b)
    (p' (s' a') b')
identityRightProfunctor =
  iso
    (\(BiId x) -> rmap runIdentity x)
    (BiId . rmap Identity)
{-# INLINE identityRightProfunctor #-}

-- |
-- >>> view identityRightProfunctorBifunctor (BiId (Tagged (Identity True)) :: BiIdIdentityRight Tagged [] Int Bool)
-- Tagged True
identityRightProfunctorBifunctor ::
  (Profunctor p, Bifunctor p') =>
  Iso
    (BiIdIdentityRight p s a b)
    (BiIdIdentityRight p' s' a' b')
    (p (s a) b)
    (p' (s' a') b')
identityRightProfunctorBifunctor =
  iso
    (\(BiId x) -> rmap runIdentity x)
    (BiId . second Identity)
{-# INLINE identityRightProfunctorBifunctor #-}

-- |
-- >>> view identityRightBifunctorProfunctor (BiId (Tagged (Identity True)) :: BiIdIdentityRight Tagged [] Int Bool)
-- Tagged True
identityRightBifunctorProfunctor ::
  (Bifunctor p, Profunctor p') =>
  Iso
    (BiIdIdentityRight p s a b)
    (BiIdIdentityRight p' s' a' b')
    (p (s a) b)
    (p' (s' a') b')
identityRightBifunctorProfunctor =
  iso
    (\(BiId x) -> second runIdentity x)
    (BiId . rmap Identity)
{-# INLINE identityRightBifunctorProfunctor #-}

-- |
-- >>> view identityRightBifunctor (BiId ([1,2], Identity True) :: BiIdIdentityRight (,) [] Int Bool)
-- ([1,2],True)
--
-- >>> view (from identityRightBifunctor) ([1,2], True) :: BiIdIdentityRight (,) [] Int Bool
-- BiId ([1,2],Identity True)
identityRightBifunctor ::
  (Bifunctor p, Bifunctor p') =>
  Iso
    (BiIdIdentityRight p s a b)
    (BiIdIdentityRight p' s' a' b')
    (p (s a) b)
    (p' (s' a') b')
identityRightBifunctor =
  iso
    (\(BiId x) -> second runIdentity x)
    (BiId . second Identity)
{-# INLINE identityRightBifunctor #-}

-- |
-- >>> view identityLeftProfunctor (BiId (Tagged (Identity True)) :: BiIdIdentityLeft Tagged Identity Int Bool)
-- Tagged (Identity True)
--
-- >>> view (from identityLeftProfunctor) (Tagged (Identity True)) :: BiIdIdentityLeft Tagged Identity Int Bool
-- BiId (Tagged (Identity True))
identityLeftProfunctor ::
  (Profunctor p, Profunctor p') =>
  Iso
    (BiIdIdentityLeft p t a b)
    (BiIdIdentityLeft p' t' a' b')
    (p a (t b))
    (p' a' (t' b'))
identityLeftProfunctor =
  iso
    (\(BiId x) -> lmap Identity x)
    (BiId . lmap runIdentity)
{-# INLINE identityLeftProfunctor #-}

-- |
-- >>> view identityLeftProfunctorBifunctor (BiId (Tagged (Identity True)) :: BiIdIdentityLeft Tagged Identity Int Bool)
-- Tagged (Identity True)
identityLeftProfunctorBifunctor ::
  (Profunctor p, Bifunctor p') =>
  Iso
    (BiIdIdentityLeft p t a b)
    (BiIdIdentityLeft p' t' a' b')
    (p a (t b))
    (p' a' (t' b'))
identityLeftProfunctorBifunctor =
  iso
    (\(BiId x) -> lmap Identity x)
    (BiId . first Identity)
{-# INLINE identityLeftProfunctorBifunctor #-}

-- |
-- >>> view identityLeftBifunctorProfunctor (BiId (Tagged (Identity True)) :: BiIdIdentityLeft Tagged Identity Int Bool)
-- Tagged (Identity True)
identityLeftBifunctorProfunctor ::
  (Bifunctor p, Profunctor p') =>
  Iso
    (BiIdIdentityLeft p t a b)
    (BiIdIdentityLeft p' t' a' b')
    (p a (t b))
    (p' a' (t' b'))
identityLeftBifunctorProfunctor =
  iso
    (\(BiId x) -> first runIdentity x)
    (BiId . lmap runIdentity)
{-# INLINE identityLeftBifunctorProfunctor #-}

-- |
-- >>> view identityLeftBifunctor (BiId (Identity 3, Identity True) :: BiIdIdentityLeft (,) Identity Int Bool)
-- (3,Identity True)
--
-- >>> view (from identityLeftBifunctor) (3, Identity True) :: BiIdIdentityLeft (,) Identity Int Bool
-- BiId (Identity 3,Identity True)
identityLeftBifunctor ::
  (Bifunctor p, Bifunctor p') =>
  Iso
    (BiIdIdentityLeft p t a b)
    (BiIdIdentityLeft p' t' a' b')
    (p a (t b))
    (p' a' (t' b'))
identityLeftBifunctor =
  iso
    (\(BiId x) -> first runIdentity x)
    (BiId . first Identity)
{-# INLINE identityLeftBifunctor #-}

instance
  (BiId p s t a b ~ x) =>
  Rewrapped (BiId p s' t' a' b') x

-- |
-- >>> view _Wrapped' (BiId ([1,2,3], Identity True))
-- ([1,2,3],Identity True)
instance Wrapped (BiId p s t a b) where
  type
    Unwrapped (BiId p s t a b) =
      p (s a) (t b)
  _Wrapped' =
    iso (\(BiId x) -> x) BiId
  {-# INLINE _Wrapped' #-}

-- |
-- >>> view __Wrapped (BiId ([1,2,3], Identity True))
-- ([1,2,3],Identity True)
--
-- >>> view (from __Wrapped) ([1,2,3], Identity True) :: BiId (,) [] Identity Int Bool
-- BiId ([1,2,3],Identity True)
--
-- >>> over __Wrapped (\(xs, Identity b) -> (fmap (+1) xs, Identity (not b))) (BiId ([1,2,3], Identity True))
-- BiId ([2,3,4],Identity False)
__Wrapped ::
  Iso
    (BiId p s t a b)
    (BiId p' s' t' a' b')
    (p (s a) (t b))
    (p' (s' a') (t' b'))
__Wrapped =
  iso
    (\(BiId x) -> x)
    BiId
{-# INLINE __Wrapped #-}

-- |
-- >>> liftEq (==) (BiId ([1,2], Identity True)) (BiId ([1,2], Identity True))
-- True
--
-- >>> liftEq (==) (BiId ([1,2], Identity True)) (BiId ([1,2], Identity False))
-- False
instance (Eq1 (p (s a)), Eq1 t) => Eq1 (BiId p s t a) where
  liftEq f (BiId x) (BiId y) =
    liftEq (liftEq f) x y
  {-# INLINE liftEq #-}

-- |
-- >>> liftCompare compare (BiId ([1], Identity 'a')) (BiId ([1], Identity 'b'))
-- LT
instance (Ord1 (p (s a)), Ord1 t) => Ord1 (BiId p s t a) where
  liftCompare f (BiId x) (BiId y) =
    liftCompare (liftCompare f) x y
  {-# INLINE liftCompare #-}

-- |
-- >>> liftShowsPrec showsPrec showList 0 (BiId ([1,2], Identity True)) ""
-- "BiId ([1,2],Identity True)"
instance (Show1 (p (s a)), Show1 t) => Show1 (BiId p s t a) where
  liftShowsPrec sp l d (BiId x) =
    showParen (d > 10) $ showString "BiId " . liftShowsPrec (liftShowsPrec sp l) (liftShowList sp l) 11 x
  {-# INLINE liftShowsPrec #-}

-- |
-- >>> liftEq2 (==) (==) (BiId ([1,2], Identity True)) (BiId ([1,2], Identity True))
-- True
--
-- >>> liftEq2 (==) (==) (BiId ([1,2], Identity True)) (BiId ([3,4], Identity True))
-- False
instance (Eq2 p, Eq1 s, Eq1 t) => Eq2 (BiId p s t) where
  liftEq2 f g (BiId x) (BiId y) =
    liftEq2 (liftEq f) (liftEq g) x y
  {-# INLINE liftEq2 #-}

-- |
-- >>> liftCompare2 compare compare (BiId ([1], Identity 'a')) (BiId ([2], Identity 'a'))
-- LT
instance (Ord2 p, Ord1 s, Ord1 t) => Ord2 (BiId p s t) where
  liftCompare2 f g (BiId x) (BiId y) =
    liftCompare2 (liftCompare f) (liftCompare g) x y
  {-# INLINE liftCompare2 #-}

-- |
-- >>> liftShowsPrec2 showsPrec showList showsPrec showList 0 (BiId ([1,2], Identity True)) ""
-- "BiId ([1,2],Identity True)"
instance (Show2 p, Show1 s, Show1 t) => Show2 (BiId p s t) where
  liftShowsPrec2 spa la spb lb d (BiId x) =
    showParen (d > 10) $ showString "BiId " . liftShowsPrec2 (liftShowsPrec spa la) (liftShowList spa la) (liftShowsPrec spb lb) (liftShowList spb lb) 11 x
  {-# INLINE liftShowsPrec2 #-}

-- |
-- >>> dimap (+1) (*2) (BiId (Tagged (Identity 3))) :: BiId Tagged [] Identity Int Int
-- BiId (Tagged (Identity 6))
instance (Profunctor p, Functor s, Functor t) => Profunctor (BiId p s t) where
  dimap f g (BiId x) =
    BiId (dimap (fmap f) (fmap g) x)
  {-# INLINE dimap #-}
  lmap f (BiId x) =
    BiId (lmap (fmap f) x)
  {-# INLINE lmap #-}
  rmap f (BiId x) =
    BiId (rmap (fmap f) x)
  {-# INLINE rmap #-}

-- |
-- >>> let f = first' (BiId id :: BiId (->) Identity Identity Int Int)
-- >>> (\(BiId g) -> g) f (Identity (3, 'x'))
-- Identity (3,'x')
instance (Strong p, Comonad s, Functor t) => Strong (BiId p s t) where
  first' (BiId x) =
    BiId
      ( dimap
          (\sac -> (fmap fst sac, snd (extract sac)))
          (\(tb, c) -> fmap (, c) tb)
          (first' x)
      )
  {-# INLINE first' #-}
  second' (BiId x) =
    BiId
      ( dimap
          (\sca -> (fst (extract sca), fmap snd sca))
          (\(c, tb) -> fmap (c,) tb)
          (second' x)
      )
  {-# INLINE second' #-}

-- |
-- >>> let f = left' (BiId id :: BiId (->) Identity Identity Int Int)
-- >>> (\(BiId g) -> g) f (Identity (Left 3))
-- Identity (Left 3)
instance (Choice p, Traversable s, Applicative t) => Choice (BiId p s t) where
  left' (BiId x) =
    BiId
      ( dimap
          (either Right Left . traverse (either Right Left))
          (either (fmap Left) (pure . Right))
          (left' x)
      )
  {-# INLINE left' #-}
  right' (BiId x) =
    BiId
      ( dimap
          (either Left Right . traverse (either Left Right))
          (either (pure . Left) (fmap Right))
          (right' x)
      )
  {-# INLINE right' #-}

-- |
-- >>> let BiId f = closed (BiId id :: BiId (->) Identity Identity Int Int)
-- >>> runIdentity (f (Identity (const 7))) 'x'
-- 7
instance (Closed p, Distributive s, Distributive t) => Closed (BiId p s t) where
  closed (BiId x) =
    BiId (dimap distribute distribute (closed x))
  {-# INLINE closed #-}

-- |
-- >>> bimap (+1) not (BiId ([1,2,3], Identity True))
-- BiId ([2,3,4],Identity False)
instance (Bifunctor p, Functor s, Functor t) => Bifunctor (BiId p s t) where
  bimap f g (BiId x) =
    BiId (bimap (fmap f) (fmap g) x)
  {-# INLINE bimap #-}
  first f (BiId x) =
    BiId (first (fmap f) x)
  {-# INLINE first #-}
  second f (BiId x) =
    BiId (second (fmap f) x)
  {-# INLINE second #-}

-- |
-- >>> bifoldMap Sum Sum (BiId ([1,2,3], Identity 4))
-- Sum {getSum = 10}
instance (Bifoldable p, Foldable s, Foldable t) => Bifoldable (BiId p s t) where
  bifoldMap f g (BiId x) =
    bifoldMap (foldMap f) (foldMap g) x
  {-# INLINE bifoldMap #-}

-- |
-- >>> bifoldMap1 Sum Sum (BiId (Identity 3, Identity 4))
-- Sum {getSum = 7}
instance (Bifoldable1 p, Foldable1 s, Foldable1 t) => Bifoldable1 (BiId p s t) where
  bifoldMap1 f g (BiId x) =
    bifoldMap1 (foldMap1 f) (foldMap1 g) x
  {-# INLINE bifoldMap1 #-}

-- |
-- >>> bitraverse (\x -> if x > 2 then Nothing else Just (x * 10)) (\x -> Just (not x)) (BiId ([1,2], Identity True))
-- Just (BiId ([10,20],Identity False))
--
-- >>> bitraverse (\x -> if x > 2 then Nothing else Just (x * 10)) (\x -> Just (not x)) (BiId ([1,3], Identity True))
-- Nothing
instance (Bitraversable p, Traversable s, Traversable t) => Bitraversable (BiId p s t) where
  bitraverse f g (BiId x) =
    BiId <$> bitraverse (traverse f) (traverse g) x
  {-# INLINE bitraverse #-}

-- |
-- >>> bitraverse1 Just Just (BiId (Identity 3, Identity True))
-- Just (BiId (Identity 3,Identity True))
instance (Bitraversable1 p, Traversable1 s, Traversable1 t) => Bitraversable1 (BiId p s t) where
  bitraverse1 f g (BiId x) =
    BiId <$> bitraverse1 (traverse1 f) (traverse1 g) x
  {-# INLINE bitraverse1 #-}

-- |
-- >>> fmap (+1) (BiId ([1,2,3], Identity 4))
-- BiId ([1,2,3],Identity 5)
instance (Functor (p (s a)), Functor t) => Functor (BiId p s t a) where
  fmap f (BiId x) =
    BiId (fmap (fmap f) x)
  {-# INLINE fmap #-}

-- |
-- >>> foldMap Sum (BiId ([1,2,3], Identity 4))
-- Sum {getSum = 4}
instance (Foldable (p (s a)), Foldable t) => Foldable (BiId p s t a) where
  foldMap f (BiId x) =
    foldMap (foldMap f) x
  {-# INLINE foldMap #-}

-- |
-- >>> traverse (\x -> if x > 3 then Nothing else Just (x * 10)) (BiId ([1,2], Identity 3))
-- Just (BiId ([1,2],Identity 30))
--
-- >>> traverse (\x -> if x > 3 then Nothing else Just (x * 10)) (BiId ([1,2], Identity 4))
-- Nothing
instance (Traversable (p (s a)), Traversable t) => Traversable (BiId p s t a) where
  traverse f (BiId x) =
    BiId <$> traverse (traverse f) x
  {-# INLINE traverse #-}

-- |
-- >>> (BiId ("", Identity (+1)) :: BiId (,) [] Identity Char (Int -> Int)) <.> BiId ("", Identity 10)
-- BiId ("",Identity 11)
instance (Apply (p (s a)), Apply t) => Apply (BiId p s t a) where
  BiId x <.> BiId y =
    BiId (liftF2 (<.>) x y)
  {-# INLINE (<.>) #-}

-- |
-- >>> pure 7 :: BiId (,) [] Identity Int Int
-- BiId ([],Identity 7)
--
-- >>> (BiId ("", Identity (+1)) :: BiId (,) [] Identity Char (Int -> Int)) <*> BiId ("", Identity 10)
-- BiId ("",Identity 11)
instance (Applicative (p (s a)), Applicative t) => Applicative (BiId p s t a) where
  pure b =
    BiId (pure (pure b))
  {-# INLINE pure #-}
  BiId x <*> BiId y =
    BiId (liftA2 (<*>) x y)
  {-# INLINE (<*>) #-}

-- |
-- >>> BiId ("hello", Identity 3) >>- (\b -> BiId ("!", Identity (b + 1)))
-- BiId ("hello!",Identity 4)
instance (Apply (p (s a)), Monad (p (s a)), Apply t, Traversable t, Monad t) => Bind (BiId p s t a) where
  BiId x >>- f =
    BiId (x >>= \tb -> fmap join (mapM (\b -> let BiId y = f b in y) tb))
  {-# INLINE (>>-) #-}

-- |
-- >>> BiId ("hello", Identity 3) >>= (\b -> BiId ("!", Identity (b + 1)))
-- BiId ("hello!",Identity 4)
instance (Monad (p (s a)), Traversable t, Monad t) => Monad (BiId p s t a) where
  BiId x >>= f =
    BiId (x >>= \tb -> fmap join (mapM (\b -> let BiId y = f b in y) tb))
  {-# INLINE (>>=) #-}

-- |
-- >>> bipure 'a' True :: BiId (,) Identity Identity Char Bool
-- BiId (Identity 'a',Identity True)
instance (Biapplicative p, Applicative s, Applicative t) => Biapplicative (BiId p s t) where
  bipure a b =
    BiId (bipure (pure a) (pure b))
  {-# INLINE bipure #-}
  BiId x <<*>> BiId y =
    BiId (biliftA2 (liftA2 ($)) (liftA2 ($)) x y)
  {-# INLINE (<<*>>) #-}

-- |
-- >>> import Control.Lens (imap)
-- >>> imap (\(i, j) x -> (i, j, x)) (BiId (["hello", "world"], Identity 7))
-- BiId (["hello","world"],Identity (["hello","world"],(),7))
instance (FunctorWithIndex i (p (s a)), FunctorWithIndex j t) => FunctorWithIndex (i, j) (BiId p s t a) where
  imap f (BiId x) =
    BiId (imap (\i -> imap (\j -> f (i, j))) x)
  {-# INLINE imap #-}

-- |
-- >>> import Control.Lens (ifoldMap)
-- >>> ifoldMap (\(i, _) x -> [(i, x)]) (BiId (["hello", "world"], Identity 7))
-- [(["hello","world"],7)]
instance (FoldableWithIndex i (p (s a)), Foldable (p (s a)), FoldableWithIndex j t, Foldable t) => FoldableWithIndex (i, j) (BiId p s t a) where
  ifoldMap f (BiId x) =
    ifoldMap (\i -> ifoldMap (\j -> f (i, j))) x
  {-# INLINE ifoldMap #-}

-- |
-- >>> import Control.Lens (itraverse)
-- >>> itraverse (\(_, _) x -> Just (x + 1)) (BiId (["hello"], Identity 7))
-- Just (BiId (["hello"],Identity 8))
instance (TraversableWithIndex i (p (s a)), Traversable (p (s a)), FoldableWithIndex i (p (s a)), Foldable (p (s a)), TraversableWithIndex j t, Traversable t, FoldableWithIndex j t, Foldable t, Functor (p (s a)), Functor t) => TraversableWithIndex (i, j) (BiId p s t a) where
  itraverse f (BiId x) =
    BiId <$> itraverse (\i -> itraverse (\j -> f (i, j))) x
  {-# INLINE itraverse #-}

-- |
-- >>> select (BiId ("", Identity (Right 7))) (BiId ("x", Identity (+1)))
-- BiId ("x",Identity 7)
--
-- >>> select (BiId ("", Identity (Left 3))) (BiId ("x", Identity (+1)))
-- BiId ("x",Identity 4)
instance (Applicative (p (s a)), Selective t) => Selective (BiId p s t a) where
  select (BiId x) (BiId y) =
    BiId (liftA2 select x y)
  {-# INLINE select #-}

instance (Alt (p (s a)), Functor (p (s a)), Functor t) => Alt (BiId p s t a) where
  BiId x <!> BiId y =
    BiId (x <!> y)
  {-# INLINE (<!>) #-}

instance (Alternative (p (s a)), Applicative t) => Alternative (BiId p s t a) where
  BiId x <|> BiId y =
    BiId (x <|> y)
  {-# INLINE (<|>) #-}
  empty =
    BiId empty
  {-# INLINE empty #-}

instance (Plus (p (s a)), Functor (p (s a)), Functor t) => Plus (BiId p s t a) where
  zero =
    BiId zero
  {-# INLINE zero #-}

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> getPredicate ((\(BiId (Tagged x)) -> x) (contramap length (BiId (Tagged (Predicate (> 3))) :: BiId Tagged [] Predicate Int Int))) "hello"
-- True
instance (Functor (p (s a)), Contravariant t) => Contravariant (BiId p s t a) where
  contramap f (BiId x) =
    BiId (fmap (contramap f) x)
  {-# INLINE contramap #-}

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> import Data.Functor.Contravariant.Divisible (divided)
-- >>> let BiId (Tagged p) = divided (BiId (Tagged (Predicate even))) (BiId (Tagged (Predicate (> 0)))) :: BiId Tagged [] Predicate Int (Int, Int) in getPredicate p (4, 1)
-- True
instance (Applicative (p (s a)), Divisible t) => Divisible (BiId p s t a) where
  divide f (BiId x) (BiId y) =
    BiId (liftA2 (divide f) x y)
  {-# INLINE divide #-}
  conquer =
    BiId (pure conquer)
  {-# INLINE conquer #-}

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> import Data.Functor.Contravariant.Divisible (chosen)
-- >>> let BiId (Tagged p) = chosen (BiId (Tagged (Predicate even))) (BiId (Tagged (Predicate (> 0)))) :: BiId Tagged [] Predicate Int (Either Int Int) in getPredicate p (Left 4)
-- True
instance (Applicative (p (s a)), Decidable t) => Decidable (BiId p s t a) where
  choose f (BiId x) (BiId y) =
    BiId (liftA2 (choose f) x y)
  {-# INLINE choose #-}
  lose f =
    BiId (pure (lose f))
  {-# INLINE lose #-}

-- |
-- >>> let f = unfirst (BiId (Tagged (Identity (True, 'x')))) :: BiId Tagged Identity Identity Int Bool
-- >>> (\(BiId (Tagged x)) -> x) f
-- Identity True
instance (Costrong p, Functor s, Comonad t) => Costrong (BiId p s t) where
  unfirst (BiId x) =
    BiId
      ( unfirst
          ( dimap
              (\(sa, d) -> fmap (, d) sa)
              (\tbd -> (fmap fst tbd, snd (extract tbd)))
              x
          )
      )
  {-# INLINE unfirst #-}
  unsecond (BiId x) =
    BiId
      ( unsecond
          ( dimap
              (\(d, sa) -> fmap (d,) sa)
              (\tdb -> (fst (extract tdb), fmap snd tdb))
              x
          )
      )
  {-# INLINE unsecond #-}

-- |
-- >>> let BiId f = unleft (BiId id :: BiId (->) Identity Identity (Either Int Char) (Either Int Char))
-- >>> f (Identity 7)
-- Identity 7
instance (Cochoice p, Applicative s, Traversable t) => Cochoice (BiId p s t) where
  unleft (BiId x) =
    BiId
      ( unleft
          ( dimap
              (either (fmap Left) (pure . Right))
              (either Right Left . traverse (either Right Left))
              x
          )
      )
  {-# INLINE unleft #-}
  unright (BiId x) =
    BiId
      ( unright
          ( dimap
              (either (pure . Left) (fmap Right))
              (either Left Right . traverse (either Left Right))
              x
          )
      )
  {-# INLINE unright #-}

-- |
-- >>> BiId ([1,2], [3,4]) <> BiId ([5], [6]) :: BiId (,) [] [] Int Int
-- BiId ([1,2,5],[3,4,6])
deriving newtype instance (Semigroup (p (s a) (t b))) => Semigroup (BiId p s t a b)

-- |
-- >>> mempty :: BiId (,) [] [] Int Int
-- BiId ([],[])
deriving newtype instance (Monoid (p (s a) (t b))) => Monoid (BiId p s t a b)

-- |
-- >>> duplicated (BiId (Identity 7, Identity True))
-- BiId (Identity 7,Identity (BiId (Identity 7,Identity True)))
instance (Comonad (p (s a)), Comonad t) => Extend (BiId p s t a) where
  duplicated (BiId x) =
    BiId (extend (\px -> extend (\tb -> BiId (fmap (const tb) px)) (extract px)) x)
  {-# INLINE duplicated #-}

-- |
-- >>> extract (BiId (Identity 7, Identity True))
-- True
instance (Comonad (p (s a)), Comonad t) => Comonad (BiId p s t a) where
  extract (BiId x) =
    extract (extract x)
  {-# INLINE extract #-}
  duplicate (BiId x) =
    BiId (extend (\px -> extend (\tb -> BiId (fmap (const tb) px)) (extract px)) x)
  {-# INLINE duplicate #-}

-- |
-- >>> foldMap1 Sum (BiId (Identity "hello", Identity 7))
-- Sum {getSum = 7}
instance (Foldable1 (p (s a)), Foldable1 t) => Foldable1 (BiId p s t a) where
  foldMap1 f (BiId x) =
    foldMap1 (foldMap1 f) x
  {-# INLINE foldMap1 #-}

-- |
-- >>> traverse1 Just (BiId (Identity "hello", Identity 7))
-- Just (BiId (Identity "hello",Identity 7))
instance (Traversable1 (p (s a)), Traversable1 t) => Traversable1 (BiId p s t a) where
  traverse1 f (BiId x) =
    BiId <$> traverse1 (traverse1 f) x
  {-# INLINE traverse1 #-}

instance (MonadPlus (p (s a)), Monad t, Traversable t) => MonadPlus (BiId p s t a)

-- |
-- >>> distribute [BiId (Tagged (Identity 1)), BiId (Tagged (Identity 2))] :: BiId Tagged [] Identity Int [Int]
-- BiId (Tagged (Identity [1,2]))
instance (Distributive (p (s a)), Distributive t) => Distributive (BiId p s t a) where
  distribute x =
    BiId (fmap distribute (distribute (fmap (\(BiId y) -> y) x)))
  {-# INLINE distribute #-}
  collect f x =
    distribute (fmap f x)
  {-# INLINE collect #-}

instance (MonadZip (p (s a)), MonadZip t, Traversable t, Monad t, Monad (p (s a))) => MonadZip (BiId p s t a) where
  mzipWith f (BiId x) (BiId y) =
    BiId (mzipWith (mzipWith f) x y)
  {-# INLINE mzipWith #-}

instance (MonadFail (p (s a)), Traversable t, Monad t) => MonadFail (BiId p s t a) where
  fail s =
    BiId (fail s)
  {-# INLINE fail #-}

instance (MonadIO (p (s a)), Applicative t, Traversable t, Monad t) => MonadIO (BiId p s t a) where
  liftIO =
    BiId . fmap pure . liftIO
  {-# INLINE liftIO #-}

-- |
-- >>> import Control.Monad.Reader (runReader)
-- >>> (\(BiId f) -> f (Identity 42)) (ask :: BiId (->) Identity Identity Int (Identity Int))
-- Identity (Identity 42)
instance (MonadReader r (p (s a)), Traversable t, Monad t) => MonadReader r (BiId p s t a) where
  ask =
    BiId (fmap pure ask)
  {-# INLINE ask #-}
  local f (BiId x) =
    BiId (local f x)
  {-# INLINE local #-}
  reader f =
    BiId (fmap pure (reader f))
  {-# INLINE reader #-}

instance (MonadState st (p (s a)), Traversable t, Monad t) => MonadState st (BiId p s t a) where
  get =
    BiId (fmap pure get)
  {-# INLINE get #-}
  put =
    BiId . fmap pure . put
  {-# INLINE put #-}
  state f =
    BiId (fmap pure (state f))
  {-# INLINE state #-}

instance (MonadWriter w (p (s a)), Comonad t, Traversable t, Monad t) => MonadWriter w (BiId p s t a) where
  writer aw =
    BiId (fmap pure (writer aw))
  {-# INLINE writer #-}
  tell =
    BiId . fmap pure . tell
  {-# INLINE tell #-}
  listen (BiId x) =
    BiId (fmap (\(tb, w) -> fmap (, w) tb) (listen x))
  {-# INLINE listen #-}
  pass (BiId x) =
    BiId (pass (fmap (\twf -> (fmap fst twf, snd (extract twf))) x))
  {-# INLINE pass #-}

instance (MonadError e (p (s a)), Traversable t, Monad t) => MonadError e (BiId p s t a) where
  throwError =
    BiId . fmap pure . throwError
  {-# INLINE throwError #-}
  catchError (BiId x) f =
    BiId (catchError x (\e -> let BiId y = f e in y))
  {-# INLINE catchError #-}

instance (MonadCont (p (s a)), Traversable t, Monad t) => MonadCont (BiId p s t a) where
  callCC f =
    BiId (callCC (\k -> let BiId x = f (BiId . k . pure) in x))
  {-# INLINE callCC #-}

instance (MonadRWS r w st (p (s a)), Comonad t, Traversable t, Monad t) => MonadRWS r w st (BiId p s t a)