Id.hs

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

-- |
-- @Id f a@ — a newtype around @f a@, with optics and instances for switching
-- the type constructor @f@.
module Data.Id
  ( -- * Id data type
    Id (..),

    -- * Functions
    unId,
    mapId,

    -- * Type aliases
    IdProxy,
    IdMaybe,
    IdIdentity,
    IdEither,
    IdWriter,
    IdList,
    IdNonEmpty,
    IdConst,
    IdTagged,

    -- * Type classes

    -- ** GetterId
    GetterId (..),

    -- ** HasId
    HasId (..),

    -- ** ReviewId
    ReviewId (..),

    -- ** AsId
    AsId (..),

    -- * Optics
    __Wrapped,
    __Unwrapped,
    idIdentity,
    idTagged,
    idProxy,
    just,
    rejust,
    nothing,
    renothing,
  )
where

import Control.Applicative (Alternative)
import Control.Comonad (Comonad (..))
import Control.DeepSeq (NFData (..), NFData1 (..))
import Control.Lens
  ( FoldableWithIndex (..),
    FunctorWithIndex (..),
    Getter,
    Iso,
    Lens',
    Prism,
    Prism',
    Review,
    Rewrapped,
    TraversableWithIndex (..),
    Wrapped (..),
    iso,
    lens,
    over,
    prism',
    re,
    review,
    to,
    unto,
    view,
    _Just,
    _Nothing,
    _Unwrapped,
    _Wrapped,
  )
import Control.Monad (MonadPlus (..))
import Control.Monad.Cont (MonadCont (..))
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Fix (MonadFix (..))
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.Trans.Class (MonadTrans (..))
import Control.Monad.Writer (MonadWriter (..))
import Control.Monad.Zip (MonadZip (..))
import Control.Selective (Selective (..))
import Data.Data (Data)
import Data.Distributive (Distributive (..))
import Data.Functor.Alt (Alt ((<!>)))
import Data.Functor.Apply (Apply)
import Data.Functor.Bind (Bind ((>>-)))
import Data.Functor.Bind.Trans (BindTrans (..))
import Data.Functor.Classes
  ( Eq1 (..),
    Ord1 (..),
    Show1 (..),
  )
import Data.Functor.Const (Const)
import Data.Functor.Contravariant (Contravariant (..))
import Data.Functor.Contravariant.Divisible (Decidable (..), Divisible (..))
import Data.Functor.Extend (Extend (..))
import Data.Functor.Identity (Identity (Identity, runIdentity))
import Data.Functor.Plus (Plus (..))
import Data.Hashable (Hashable (..))
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy (Proxy (..))
import Data.Semigroup.Foldable (Foldable1)
import Data.Semigroup.Traversable (Traversable1 (traverse1))
import Data.Tagged (Tagged (Tagged), untag)
import GHC.Generics (Generic, Generic1)

-- $setup
-- >>> import Control.Applicative (empty, (<|>))
-- >>> import Control.Lens (set, preview, review, from)
-- >>> import Data.Functor.Apply ((<.>))
-- >>> import Data.Functor.Const (Const(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> import Data.Semigroup (Sum(..))
-- >>> import Data.Semigroup.Foldable (foldMap1)

-- |
-- >>> Id [1,2,3]
-- Id [1,2,3]
--
-- >>> Id [1,2,3] == Id [1,2,3]
-- True
--
-- >>> Id [1,2,3] == Id [4,5,6]
-- False
--
-- >>> compare (Id [1,2,3]) (Id [1,2,4])
-- LT
--
-- >>> Id [1,2,3] <= Id [1,2,3]
-- True
newtype Id f a
  = Id (f a)
  deriving stock (Eq, Ord, Show, Data, Generic, Generic1)

-- Instances derived via GeneralizedNewtypeDeriving
-- |
-- >>> liftEq (==) (Id [1,2,3]) (Id [1,2,3])
-- True
--
-- >>> liftEq (==) (Id [1,2,3]) (Id [4,5,6])
-- False
--
-- >>> liftEq (\_ _ -> True) (Id [1,2,3]) (Id [4,5,6])
-- True
deriving newtype instance (Eq1 f) => Eq1 (Id f)

-- |
-- >>> liftCompare compare (Id [1,2,3]) (Id [1,2,4])
-- LT
--
-- >>> liftCompare compare (Id [1,2,3]) (Id [1,2,3])
-- EQ
--
-- >>> liftCompare (\_ _ -> GT) (Id [1]) (Id [2])
-- GT
deriving newtype instance (Ord1 f) => Ord1 (Id f)

-- |
-- >>> liftShowsPrec showsPrec showList 0 (Id [1,2,3]) ""
-- "Id [1,2,3]"
--
-- >>> liftShowsPrec showsPrec showList 0 (Id (Just 'x')) ""
-- "Id (Just 'x')"
--
-- >>> liftShowsPrec showsPrec showList 11 (Id [1,2,3]) ""
-- "(Id [1,2,3])"
instance (Show1 f) => Show1 (Id f) where
  liftShowsPrec sp l d (Id x) =
    showParen (d > 10) $ showString "Id " . liftShowsPrec sp l 11 x
  {-# INLINE liftShowsPrec #-}


instance
  (Id f a ~ x) =>
  Rewrapped (Id f a') x

-- |
-- >>> view _Wrapped' (Id [1,2,3])
-- [1,2,3]
--
-- >>> set _Wrapped' [4,5] (Id [1,2,3])
-- Id [4,5]
instance Wrapped (Id f a) where
  type
    Unwrapped (Id f a) =
      f a
  _Wrapped' =
    iso (\(Id x) -> x) Id
  {-# INLINE _Wrapped' #-}

-- |
-- >>> view __Wrapped (Id [1,2,3])
-- [1,2,3]
--
-- >>> view (from __Wrapped) [1,2,3] :: Id [] Int
-- Id [1,2,3]
--
-- >>> over __Wrapped (fmap (+1)) (Id [1,2,3])
-- Id [2,3,4]
{-# SPECIALIZE __Wrapped ::
  Iso (IdMaybe a) (IdMaybe a') (Maybe a) (Maybe a')
  #-}
{-# SPECIALIZE __Wrapped ::
  Iso (IdIdentity a) (IdIdentity a') (Identity a) (Identity a')
  #-}
{-# SPECIALIZE __Wrapped ::
  Iso (IdEither e a) (IdEither e' a') (Either e a) (Either e' a')
  #-}
{-# SPECIALIZE __Wrapped ::
  Iso (IdWriter w a) (IdWriter w' a') (w, a) (w', a')
  #-}
{-# SPECIALIZE __Wrapped ::
  Iso (IdList a) (IdList a') [a] [a']
  #-}
{-# SPECIALIZE __Wrapped ::
  Iso (IdNonEmpty a) (IdNonEmpty a') (NonEmpty a) (NonEmpty a')
  #-}
{-# SPECIALIZE __Wrapped ::
  Iso (IdConst c a) (IdConst c' a') (Const c a) (Const c' a')
  #-}
__Wrapped ::
  Iso
    (Id f a)
    (Id f' a')
    (f a)
    (f' a')
__Wrapped =
  iso
    (\(Id x) -> x)
    Id
{-# INLINE __Wrapped #-}

-- |
-- >>> view __Unwrapped [1,2,3] :: Id [] Int
-- Id [1,2,3]
--
-- >>> view (from __Unwrapped) (Id [1,2,3])
-- [1,2,3]
--
-- >>> over __Unwrapped (mapId (fmap (+1))) [1,2,3] :: [Int]
-- [2,3,4]
{-# SPECIALIZE __Unwrapped ::
  Iso (Maybe a) (Maybe a') (IdMaybe a) (IdMaybe a')
  #-}
{-# SPECIALIZE __Unwrapped ::
  Iso (Identity a) (Identity a') (IdIdentity a) (IdIdentity a')
  #-}
{-# SPECIALIZE __Unwrapped ::
  Iso (Either e a) (Either e' a') (IdEither e a) (IdEither e' a')
  #-}
{-# SPECIALIZE __Unwrapped ::
  Iso (w, a) (w', a') (IdWriter w a) (IdWriter w' a')
  #-}
{-# SPECIALIZE __Unwrapped ::
  Iso [a] [a'] (IdList a) (IdList a')
  #-}
{-# SPECIALIZE __Unwrapped ::
  Iso (NonEmpty a) (NonEmpty a') (IdNonEmpty a) (IdNonEmpty a')
  #-}
{-# SPECIALIZE __Unwrapped ::
  Iso (Const c a) (Const c' a') (IdConst c a) (IdConst c' a')
  #-}
__Unwrapped ::
  Iso
    (f a)
    (f' a')
    (Id f a)
    (Id f' a')
__Unwrapped =
  iso
    Id
    (\(Id x) -> x)
{-# INLINE __Unwrapped #-}

-- |
-- >>> unId (Id [1,2,3])
-- [1,2,3]
--
-- >>> unId (Id (Identity 7))
-- Identity 7
unId :: Id f a -> f a
unId (Id x) = x
{-# INLINE unId #-}

-- |
-- >>> mapId reverse (Id [1,2,3])
-- Id [3,2,1]
--
-- >>> mapId (Just . head) (Id [1,2,3])
-- Id (Just 1)
--
-- >>> mapId Identity (Id [1,2,3])
-- Id (Identity [1,2,3])
mapId :: (f a -> g b) -> Id f a -> Id g b
mapId = over __Wrapped
{-# INLINE mapId #-}

-- |
-- >>> view getId (Id [1,2,3])
-- Id [1,2,3]
--
-- >>> view getId (Id (Identity 7))
-- Id (Identity 7)
class GetterId a f x | a -> f x where
  getId ::
    Getter a (Id f x)

instance GetterId (Id f a) f a where
  getId =
    id
  {-# INLINE getId #-}

instance GetterId (Identity a) Identity a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (Maybe a) Maybe a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId [a] [] a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (NonEmpty a) NonEmpty a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (Either e a) (Either e) a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (w, a) ((,) w) a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (Const c a) (Const c) a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (Proxy a) Proxy a where
  getId =
    to Id
  {-# INLINE getId #-}

instance GetterId (Tagged s a) (Tagged s) a where
  getId =
    to Id
  {-# INLINE getId #-}

-- |
-- >>> view id' (Id [1,2,3])
-- Id [1,2,3]
--
-- >>> set id' (Id [4,5]) (Id [1,2,3])
-- Id [4,5]
class (GetterId a f x) => HasId a f x | a -> f x where
  {-# MINIMAL setId #-}
  setId ::
    Id f x -> a -> a
  id' ::
    Lens' a (Id f x)
  id' =
    lens (view getId) (flip setId)
  {-# INLINE id' #-}

instance HasId (Id f a) f a where
  setId =
    const
  {-# INLINE setId #-}

instance HasId (Identity a) Identity a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (Maybe a) Maybe a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId [a] [] a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (NonEmpty a) NonEmpty a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (Either e a) (Either e) a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (w, a) ((,) w) a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (Const c a) (Const c) a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (Proxy a) Proxy a where
  setId =
    const . unId
  {-# INLINE setId #-}

instance HasId (Tagged s a) (Tagged s) a where
  setId =
    const . unId
  {-# INLINE setId #-}

-- |
-- >>> review reviewId (Id [1,2,3]) :: Id [] Int
-- Id [1,2,3]
--
-- >>> review reviewId (Id (Identity 7)) :: IdIdentity Int
-- Id (Identity 7)
class ReviewId a f x | a -> f x where
  reviewId ::
    Review a (Id f x)

instance ReviewId (Id f a) f a where
  reviewId =
    unto id
  {-# INLINE reviewId #-}

instance ReviewId (Identity a) Identity a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (Maybe a) Maybe a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId [a] [] a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (NonEmpty a) NonEmpty a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (Either e a) (Either e) a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (w, a) ((,) w) a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (Const c a) (Const c) a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (Proxy a) Proxy a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

instance ReviewId (Tagged s a) (Tagged s) a where
  reviewId =
    unto unId
  {-# INLINE reviewId #-}

-- |
-- >>> preview _Id (Id [1,2,3])
-- Just (Id [1,2,3])
--
-- >>> review _Id (Id [1,2,3]) :: Id [] Int
-- Id [1,2,3]
class (ReviewId a f x) => AsId a f x | a -> f x where
  {-# MINIMAL matchId #-}
  matchId ::
    a -> Maybe (Id f x)
  _Id ::
    Prism' a (Id f x)
  _Id =
    prism' (review reviewId) matchId
  {-# INLINE _Id #-}

instance AsId (Id f a) f a where
  matchId =
    Just
  {-# INLINE matchId #-}

instance AsId (Identity a) Identity a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (Maybe a) Maybe a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId [a] [] a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (NonEmpty a) NonEmpty a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (Either e a) (Either e) a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (w, a) ((,) w) a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (Const c a) (Const c) a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (Proxy a) Proxy a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

instance AsId (Tagged s a) (Tagged s) a where
  matchId =
    Just . Id
  {-# INLINE matchId #-}

-- |
-- >>> Id [1,2,3] <> Id [4,5]
-- Id [1,2,3,4,5]
--
-- >>> Id "hello" <> Id " world"
-- Id "hello world"
deriving newtype instance (Semigroup (f a)) => Semigroup (Id f a)

-- |
-- >>> mempty :: Id [] Int
-- Id []
--
-- >>> Id [1,2] <> mempty
-- Id [1,2]
--
-- >>> mempty <> Id [1,2] :: Id [] Int
-- Id [1,2]
deriving newtype instance (Monoid (f a)) => Monoid (Id f a)

-- |
-- >>> fmap (+1) (Id [1,2,3])
-- Id [2,3,4]
--
-- >>> fmap (*2) (Id (Identity 5))
-- Id (Identity 10)
--
-- >>> fmap show (Id [1,2,3])
-- Id ["1","2","3"]
deriving newtype instance (Functor f) => Functor (Id f)

-- |
-- >>> Id [(+1), (*2)] <.> Id [3,4]
-- Id [4,5,6,8]
--
-- >>> Id (Identity (+1)) <.> Id (Identity 5)
-- Id (Identity 6)
deriving newtype instance (Apply f) => Apply (Id f)

-- |
-- >>> Id [(+1), (*2)] <*> Id [3,4]
-- Id [4,5,6,8]
--
-- >>> pure 7 :: Id [] Int
-- Id [7]
--
-- >>> pure 'x' :: Id Identity Char
-- Id (Identity 'x')
deriving newtype instance (Applicative f) => Applicative (Id f)

-- |
-- >>> select (Id [Right 7]) (Id [const 0])
-- Id [7]
--
-- >>> select (Id [Left 3]) (Id [(+1)])
-- Id [4]
--
-- >>> select (Id [Left 3, Right 7]) (Id [(+1), (*2)])
-- Id [4,6,7]
deriving newtype instance (Selective f) => Selective (Id f)

-- |
-- >>> Id [1,2] <!> Id [3,4]
-- Id [1,2,3,4]
--
-- >>> Id (Just 1) <!> Id (Just 2)
-- Id (Just 1)
--
-- >>> Id Nothing <!> Id (Just 2)
-- Id (Just 2)
instance (Alt f) => Alt (Id f) where
  Id x <!> Id y =
    Id (x <!> y)
  {-# INLINE (<!>) #-}

-- |
-- >>> Id [1,2] <|> Id [3,4]
-- Id [1,2,3,4]
--
-- >>> Id Nothing <|> Id (Just 2)
-- Id (Just 2)
--
-- >>> empty :: Id [] Int
-- Id []
--
-- >>> empty :: Id Maybe Int
-- Id Nothing
deriving newtype instance (Alternative f) => Alternative (Id f)

-- |
-- >>> Id [1,2,3] >>- (\x -> Id [x, x*10])
-- Id [1,10,2,20,3,30]
--
-- >>> Id (Identity 5) >>- (Id . Identity . (+1))
-- Id (Identity 6)
instance (Bind f) => Bind (Id f) where
  Id x >>- f =
    Id (x >>- view _Wrapped . f)
  {-# INLINE (>>-) #-}

-- |
-- >>> Id [1,2,3] >>= (\x -> Id [x, x*10])
-- Id [1,10,2,20,3,30]
--
-- >>> Id (Identity 5) >>= (Id . Identity . (+1))
-- Id (Identity 6)
instance (Monad f) => Monad (Id f) where
  Id x >>= f =
    Id (x >>= view _Wrapped . f)
  {-# INLINE (>>=) #-}

-- |
-- >>> foldMap show (Id [1,2,3])
-- "123"
--
-- >>> foldMap Sum (Id [1,2,3])
-- Sum {getSum = 6}
--
-- >>> foldr (:) [] (Id [1,2,3])
-- [1,2,3]
deriving newtype instance (Foldable f) => Foldable (Id f)

-- |
-- >>> foldMap1 show (Id (Identity 7))
-- "7"
deriving newtype instance (Foldable1 f) => Foldable1 (Id f)

-- |
-- >>> traverse Just (Id [1,2,3])
-- Just (Id [1,2,3])
--
-- >>> traverse (\x -> if x > 2 then Nothing else Just x) (Id [1,2,3])
-- Nothing
--
-- >>> traverse (\x -> if x > 3 then Nothing else Just x) (Id [1,2,3])
-- Just (Id [1,2,3])
instance (Traversable f) => Traversable (Id f) where
  traverse f (Id x) =
    Id <$> traverse f x
  {-# INLINE traverse #-}

-- |
-- >>> traverse1 Just (Id (Identity 7))
-- Just (Id (Identity 7))
instance (Traversable1 f) => Traversable1 (Id f) where
  traverse1 f (Id x) =
    Id <$> traverse1 f x
  {-# INLINE traverse1 #-}

-- |
-- >>> unId (liftIO (pure 7) :: Id IO Int)
-- 7
deriving newtype instance (MonadIO f) => MonadIO (Id f)

-- |
-- >>> lift [1,2,3] :: Id [] Int
-- Id [1,2,3]
--
-- >>> lift (Identity 5) :: Id Identity Int
-- Id (Identity 5)
instance MonadTrans Id where
  lift =
    Id
  {-# INLINE lift #-}

-- |
-- >>> liftB [1,2,3] :: Id [] Int
-- Id [1,2,3]
instance BindTrans Id where
  liftB =
    Id
  {-# INLINE liftB #-}

-- |
-- >>> throwError "oops" :: Id (Either String) Int
-- Id (Left "oops")
--
-- >>> catchError (Id (Left "oops")) (\_ -> Id (Right 42)) :: Id (Either String) Int
-- Id (Right 42)
deriving newtype instance (MonadError a f) => MonadError a (Id f)

-- |
-- >>> import Control.Monad.Cont (runCont)
-- >>> runCont (callCC (\k -> k (Id [7]))) unId :: [Int]
-- [7]
deriving newtype instance (MonadCont f) => MonadCont (Id f)

-- |
-- >>> import Control.Monad.Reader (runReader)
-- >>> runReader (unId ask) "hello"
-- "hello"
--
-- >>> runReader (unId (local (++" world") ask)) "hello"
-- "hello world"
deriving newtype instance (MonadReader a f) => MonadReader a (Id f)

-- |
-- >>> import Control.Monad.Writer (runWriter)
-- >>> runWriter (unId (tell "hello" >> tell " world"))
-- ((),"hello world")
--
-- >>> runWriter (unId (writer (7, "log")))
-- (7,"log")
deriving newtype instance (MonadWriter a f) => MonadWriter a (Id f)

-- |
-- >>> import Control.Monad.State (runState)
-- >>> runState (unId (get >>= \s -> put (s + 1) >> pure s)) 10
-- (10,11)
deriving newtype instance (MonadState a f) => MonadState a (Id f)

deriving newtype instance (MonadRWS r w s f) => MonadRWS r w s (Id f)

-- |
-- >>> mfix (\_ -> Id [1,2,3])
-- Id [1,2,3]
deriving newtype instance (MonadFix f) => MonadFix (Id f)

-- |
-- >>> fail "oops" :: Id Maybe Int
-- Id Nothing
deriving newtype instance (MonadFail f) => MonadFail (Id f)

-- |
-- >>> mzero :: Id [] Int
-- Id []
--
-- >>> mplus (Id [1,2]) (Id [3,4])
-- Id [1,2,3,4]
deriving newtype instance (MonadPlus f) => MonadPlus (Id f)

-- |
-- >>> mzipWith (+) (Id [1,2,3]) (Id [10,20,30])
-- Id [11,22,33]
deriving newtype instance (MonadZip f) => MonadZip (Id f)

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> getPredicate (unId (contramap length (Id (Predicate (> 3))))) "hello"
-- True
--
-- >>> getPredicate (unId (contramap length (Id (Predicate (> 3))))) "hi"
-- False
deriving newtype instance (Contravariant f) => Contravariant (Id f)

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> import Data.Functor.Contravariant.Divisible (divided)
-- >>> getPredicate (unId (divided (Id (Predicate even)) (Id (Predicate (> 0))))) (4, 1)
-- True
--
-- >>> getPredicate (unId (divided (Id (Predicate even)) (Id (Predicate (> 0))))) (3, 1)
-- False
deriving newtype instance (Divisible f) => Divisible (Id f)

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> import Data.Functor.Contravariant.Divisible (chosen)
-- >>> getPredicate (unId (chosen (Id (Predicate even)) (Id (Predicate (> 0))))) (Left 4)
-- True
--
-- >>> getPredicate (unId (chosen (Id (Predicate even)) (Id (Predicate (> 0))))) (Right 0)
-- False
deriving newtype instance (Decidable f) => Decidable (Id f)

-- |
-- >>> zero :: Id [] Int
-- Id []
deriving newtype instance (Plus f) => Plus (Id f)

-- |
-- >>> duplicated (Id (Identity 7))
-- Id (Identity (Id (Identity 7)))
instance (Extend f) => Extend (Id f) where
  duplicated (Id x) =
    Id (Id <$> duplicated x)
  {-# INLINE duplicated #-}

-- |
-- >>> extract (Id (Identity 7))
-- 7
instance (Comonad f) => Comonad (Id f) where
  extract (Id x) =
    extract x
  {-# INLINE extract #-}
  duplicate (Id x) =
    Id (Id <$> duplicate x)
  {-# INLINE duplicate #-}

-- |
-- >>> import Control.Lens (imap)
-- >>> imap (+) (Id [10,20,30])
-- Id [10,21,32]
deriving newtype instance (FunctorWithIndex i f) => FunctorWithIndex i (Id f)

-- |
-- >>> import Control.Lens (ifoldMap)
-- >>> ifoldMap (\i x -> [(i, x)]) (Id [10,20,30])
-- [(0,10),(1,20),(2,30)]
deriving newtype instance (FoldableWithIndex i f) => FoldableWithIndex i (Id f)

-- |
-- >>> import Control.Lens (itraverse)
-- >>> itraverse (\i x -> if i > 1 then Nothing else Just (x * 10)) (Id [1,2,3])
-- Nothing
--
-- >>> itraverse (\i x -> if i > 2 then Nothing else Just (x * 10)) (Id [1,2,3])
-- Just (Id [10,20,30])
instance (TraversableWithIndex i f) => TraversableWithIndex i (Id f) where
  itraverse f (Id x) =
    Id <$> itraverse f x
  {-# INLINE itraverse #-}

instance (Distributive f) => Distributive (Id f) where
  distribute x =
    Id (distribute (fmap (\(Id y) -> y) x))
  {-# INLINE distribute #-}
  collect f x =
    Id (collect ((\(Id y) -> y) . f) x)
  {-# INLINE collect #-}

deriving newtype instance (NFData (f a)) => NFData (Id f a)

deriving newtype instance (NFData1 f) => NFData1 (Id f)

deriving newtype instance (Hashable (f a)) => Hashable (Id f a)

deriving newtype instance (Num (f a)) => Num (Id f a)

deriving newtype instance (Fractional (f a)) => Fractional (Id f a)

deriving newtype instance (Floating (f a)) => Floating (Id f a)

-- |
-- >>> let x = Id Proxy :: IdProxy Int in x
-- Id Proxy
type IdProxy a =
  Id Proxy a

-- |
-- >>> Id (Just 3) :: IdMaybe Int
-- Id (Just 3)
--
-- >>> Id Nothing :: IdMaybe Int
-- Id Nothing
type IdMaybe a =
  Id Maybe a

-- |
-- >>> Id (Identity 7) :: IdIdentity Int
-- Id (Identity 7)
type IdIdentity a =
  Id Identity a

-- |
-- >>> Id (Left "err") :: IdEither String Int
-- Id (Left "err")
--
-- >>> Id (Right 7) :: IdEither String Int
-- Id (Right 7)
type IdEither e a =
  Id (Either e) a

-- |
-- >>> Id ("log", 7) :: IdWriter String Int
-- Id ("log",7)
type IdWriter w a =
  Id ((,) w) a

-- |
-- >>> Id [1,2,3] :: IdList Int
-- Id [1,2,3]
--
-- >>> Id [] :: IdList Int
-- Id []
type IdList a =
  Id [] a

-- |
-- >>> Id (1 :| [2,3]) :: IdNonEmpty Int
-- Id (1 :| [2,3])
type IdNonEmpty a =
  Id NonEmpty a

-- |
-- >>> Id (Const "hello") :: IdConst String Int
-- Id (Const "hello")
type IdConst c a =
  Id (Const c) a

-- |
-- >>> Id (Tagged 7) :: IdTagged Bool Int
-- Id (Tagged 7)
type IdTagged f a =
  Id (Tagged f) a

-- |
-- >>> view idTagged (Id (Identity 7)) :: IdTagged Bool Int
-- Id (Tagged 7)
--
-- >>> view (from idTagged) (Id (Tagged 7) :: IdTagged Bool Int) :: IdIdentity Int
-- Id (Identity 7)
{-# SPECIALIZE idTagged ::
  Iso
    (IdIdentity a)
    (IdIdentity a')
    (IdTagged f a)
    (IdTagged f a')
  #-}
idTagged ::
  (Rewrapped (f a) (f a)) =>
  Iso
    (Id f a)
    (IdIdentity a')
    (Id (Tagged s) (Unwrapped (f a)))
    (Id (Tagged s') a')
idTagged =
  iso (over __Wrapped (Tagged . view _Wrapped)) (over __Wrapped (Identity . untag))
{-# INLINE idTagged #-}

idIdentity ::
  Iso
    (IdIdentity a)
    (IdIdentity a')
    a
    a'
idIdentity =
  _Wrapped .
    iso
      runIdentity
      Identity
{-# INLINE idIdentity #-}

-- |
-- >>> view idProxy (Id Proxy :: IdProxy Int)
-- ()
--
-- >>> set idProxy () (Id Proxy :: IdProxy Int)
-- Id Proxy
idProxy ::
  Iso
    (IdProxy a)
    (IdProxy a')
    ()
    ()
idProxy =
  iso (const ()) (const (Id Proxy))
{-# INLINE idProxy #-}

-- |
-- >>> preview (just :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity Int) (IdIdentity Int)) (Id (Just 7))
-- Just (Id (Identity 7))
--
-- >>> preview (just :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity Int) (IdIdentity Int)) (Id Nothing)
-- Nothing
--
-- >>> review (just :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity Int) (IdIdentity Int)) (Id (Identity 7))
-- Id (Just 7)
{-# SPECIALIZE just ::
  Prism
    (IdMaybe a)
    (IdMaybe a')
    (IdIdentity a)
    (IdIdentity a')
  #-}
just ::
  ( Unwrapped s ~ Maybe (Unwrapped (Unwrapped a)),
    Unwrapped t ~ Maybe (Unwrapped (Unwrapped b)),
    Rewrapped s t,
    Rewrapped t s,
    Rewrapped b a,
    Rewrapped a b,
    Rewrapped (Unwrapped b) (Unwrapped a),
    Rewrapped (Unwrapped a) (Unwrapped b)
  ) =>
  Prism s t a b
just =
  _Wrapped . _Just . _Unwrapped . _Unwrapped
{-# INLINE just #-}

-- |
-- >>> view (rejust :: Getter (IdIdentity Int) (IdMaybe Int)) (Id (Identity 7))
-- Id (Just 7)
{-# SPECIALIZE rejust ::
  Getter
    (IdIdentity a)
    (IdMaybe a)
  #-}
rejust ::
  ( Unwrapped t ~ Maybe (Unwrapped (Unwrapped b)),
    Rewrapped t t,
    Rewrapped b b,
    Rewrapped (Unwrapped b) (Unwrapped b)
  ) =>
  Getter b t
rejust =
  re just
{-# INLINE rejust #-}

-- |
-- >>> preview (nothing :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity ()) (IdIdentity ())) (Id Nothing)
-- Just (Id (Identity ()))
--
-- >>> preview (nothing :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity ()) (IdIdentity ())) (Id (Just 7))
-- Nothing
--
-- >>> review (nothing :: Prism (IdMaybe Int) (IdMaybe Int) (IdIdentity ()) (IdIdentity ())) (Id (Identity ()))
-- Id Nothing
{-# SPECIALIZE nothing ::
  Prism
    (IdMaybe a)
    (IdMaybe a)
    (IdIdentity ())
    (IdIdentity ())
  #-}
nothing ::
  ( Unwrapped t ~ Maybe x,
    Unwrapped s ~ Maybe x,
    Unwrapped (Unwrapped a) ~ (),
    Unwrapped (Unwrapped b) ~ (),
    Rewrapped s t,
    Rewrapped t s,
    Rewrapped b a,
    Rewrapped a b,
    Rewrapped (Unwrapped b) (Unwrapped a),
    Rewrapped (Unwrapped a) (Unwrapped b)
  ) =>
  Prism s t a b
nothing =
  _Wrapped . _Nothing . _Unwrapped . _Unwrapped
{-# INLINE nothing #-}

-- |
-- >>> view (renothing :: Getter (IdIdentity ()) (IdMaybe Int)) (Id (Identity ()))
-- Id Nothing
{-# SPECIALIZE renothing ::
  Getter
    (IdIdentity ())
    (IdMaybe a)
  #-}
renothing ::
  ( Unwrapped t ~ Maybe x,
    Unwrapped (Unwrapped a) ~ (),
    Rewrapped t t,
    Rewrapped a a,
    Rewrapped (Unwrapped a) (Unwrapped a)
  ) =>
  Getter a t
renothing =
  re nothing
{-# INLINE renothing #-}