id-0.0.4: src/Data/Id.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# 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 (empty, (<|>)))
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 (liftShowsPrec),
  )
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 (foldMap1))
import Data.Semigroup.Traversable (Traversable1 (traverse1))
import Data.Tagged (Tagged (Tagged), untag)
import GHC.Generics (Generic, Generic1)

-- $setup
-- >>> import Control.Lens (set, preview, review, from)
-- >>> import Data.Functor.Const (Const(..))
-- >>> import Data.List.NonEmpty (NonEmpty(..))
-- >>> import Data.Semigroup (Sum(..))

-- |
-- >>> 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 (Eq, Ord, Show, Data, Generic, Generic1)

-- |
-- >>> 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
instance (Eq1 f) => Eq1 (Id f) where
  liftEq f (Id x) (Id y) =
    liftEq f x y
  {-# INLINE liftEq #-}

-- |
-- >>> 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
instance (Ord1 f) => Ord1 (Id f) where
  liftCompare f (Id x) (Id y) =
    liftCompare f x y
  {-# INLINE liftCompare #-}

-- |
-- >>> 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"
instance (Semigroup (f a)) => Semigroup (Id f a) where
  Id x <> Id y =
    Id (x <> y)
  {-# INLINE (<>) #-}

-- |
-- >>> mempty :: Id [] Int
-- Id []
--
-- >>> Id [1,2] <> mempty
-- Id [1,2]
--
-- >>> mempty <> Id [1,2] :: Id [] Int
-- Id [1,2]
instance (Monoid (f a)) => Monoid (Id f a) where
  mempty =
    Id mempty
  {-# INLINE mempty #-}

-- |
-- >>> 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"]
instance (Functor f) => Functor (Id f) where
  fmap f (Id x) =
    Id (fmap f x)
  {-# INLINE fmap #-}

-- |
-- >>> Id [(+1), (*2)] <.> Id [3,4]
-- Id [4,5,6,8]
--
-- >>> Id (Identity (+1)) <.> Id (Identity 5)
-- Id (Identity 6)
instance (Apply f) => Apply (Id f) where
  Id x <.> Id y =
    Id (x <.> y)
  {-# INLINE (<.>) #-}

-- |
-- >>> 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')
instance (Applicative f) => Applicative (Id f) where
  Id x <*> Id y =
    Id (x <*> y)
  {-# INLINE (<*>) #-}
  pure =
    Id . pure
  {-# INLINE pure #-}
  liftA2 f (Id x) (Id y) =
    Id (liftA2 f x y)
  {-# INLINE liftA2 #-}
  Id x *> Id y =
    Id (x *> y)
  {-# INLINE (*>) #-}
  Id x <* Id y =
    Id (x <* y)
  {-# INLINE (<*) #-}

-- |
-- >>> 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]
instance (Selective f) => Selective (Id f) where
  select (Id x) (Id y) =
    Id (select x y)
  {-# INLINE select #-}

-- |
-- >>> 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
instance (Alternative f) => Alternative (Id f) where
  Id x <|> Id y =
    Id (x <|> y)
  {-# INLINE (<|>) #-}
  empty =
    Id empty
  {-# INLINE empty #-}

-- |
-- >>> 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]
instance (Foldable f) => Foldable (Id f) where
  foldMap f (Id x) =
    foldMap f x
  {-# INLINE foldMap #-}
  foldr f z (Id x) =
    foldr f z x
  {-# INLINE foldr #-}
  null (Id x) =
    null x
  {-# INLINE null #-}
  length (Id x) =
    length x
  {-# INLINE length #-}

-- |
-- >>> foldMap1 show (Id (Identity 7))
-- "7"
instance (Foldable1 f) => Foldable1 (Id f) where
  foldMap1 f (Id x) =
    foldMap1 f x
  {-# INLINE foldMap1 #-}

-- |
-- >>> 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
instance (MonadIO f) => MonadIO (Id f) where
  liftIO =
    Id . liftIO
  {-# INLINE liftIO #-}

-- |
-- >>> 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)
instance (MonadError a f) => MonadError a (Id f) where
  throwError =
    Id . throwError
  {-# INLINE throwError #-}
  catchError (Id x) f =
    Id (catchError x (view _Wrapped . f))
  {-# INLINE catchError #-}

-- |
-- >>> import Control.Monad.Cont (runCont)
-- >>> runCont (callCC (\k -> k (Id [7]))) unId :: [Int]
-- [7]
instance (MonadCont f) => MonadCont (Id f) where
  callCC f =
    Id (callCC (\k -> view _Wrapped (f (Id . k))))
  {-# INLINE callCC #-}

-- |
-- >>> import Control.Monad.Reader (runReader)
-- >>> runReader (unId ask) "hello"
-- "hello"
--
-- >>> runReader (unId (local (++" world") ask)) "hello"
-- "hello world"
instance (MonadReader a f) => MonadReader a (Id f) where
  ask =
    Id ask
  {-# INLINE ask #-}
  local f (Id x) =
    Id (local f x)
  {-# INLINE local #-}
  reader =
    Id . reader
  {-# INLINE reader #-}

-- |
-- >>> import Control.Monad.Writer (runWriter)
-- >>> runWriter (unId (tell "hello" >> tell " world"))
-- ((),"hello world")
--
-- >>> runWriter (unId (writer (7, "log")))
-- (7,"log")
instance (MonadWriter a f) => MonadWriter a (Id f) where
  writer aw =
    Id (writer aw)
  {-# INLINE writer #-}
  tell =
    Id . tell
  {-# INLINE tell #-}
  listen =
    over _Wrapped listen
  {-# INLINE listen #-}
  pass =
    over _Wrapped pass
  {-# INLINE pass #-}

-- |
-- >>> import Control.Monad.State (runState)
-- >>> runState (unId (get >>= \s -> put (s + 1) >> pure s)) 10
-- (10,11)
instance (MonadState a f) => MonadState a (Id f) where
  get =
    Id get
  {-# INLINE get #-}
  put =
    Id . put
  {-# INLINE put #-}
  state =
    Id . state
  {-# INLINE state #-}

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

-- |
-- >>> mfix (\_ -> Id [1,2,3])
-- Id [1,2,3]
instance (MonadFix f) => MonadFix (Id f) where
  mfix g =
    Id (mfix (unId . g))
  {-# INLINE mfix #-}

-- |
-- >>> fail "oops" :: Id Maybe Int
-- Id Nothing
instance (MonadFail f) => MonadFail (Id f) where
  fail =
    Id . fail
  {-# INLINE fail #-}

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

-- |
-- >>> mzipWith (+) (Id [1,2,3]) (Id [10,20,30])
-- Id [11,22,33]
instance (MonadZip f) => MonadZip (Id f) where
  mzipWith f (Id x) (Id y) =
    Id (mzipWith f x y)
  {-# INLINE mzipWith #-}

-- |
-- >>> import Data.Functor.Contravariant (Predicate(..), getPredicate)
-- >>> getPredicate (unId (contramap length (Id (Predicate (> 3))))) "hello"
-- True
--
-- >>> getPredicate (unId (contramap length (Id (Predicate (> 3))))) "hi"
-- False
instance (Contravariant f) => Contravariant (Id f) where
  contramap f (Id x) =
    Id (contramap f x)
  {-# INLINE contramap #-}

-- |
-- >>> 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
instance (Divisible f) => Divisible (Id f) where
  divide f (Id x) (Id y) =
    Id (divide f x y)
  {-# INLINE divide #-}
  conquer =
    Id conquer
  {-# INLINE conquer #-}

-- |
-- >>> 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
instance (Decidable f) => Decidable (Id f) where
  choose f (Id x) (Id y) =
    Id (choose f x y)
  {-# INLINE choose #-}
  lose f =
    Id (lose f)
  {-# INLINE lose #-}

-- |
-- >>> zero :: Id [] Int
-- Id []
instance (Plus f) => Plus (Id f) where
  zero =
    Id zero
  {-# INLINE zero #-}

-- |
-- >>> 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]
instance (FunctorWithIndex i f) => FunctorWithIndex i (Id f) where
  imap f (Id x) =
    Id (imap f x)
  {-# INLINE imap #-}

-- |
-- >>> import Control.Lens (ifoldMap)
-- >>> ifoldMap (\i x -> [(i, x)]) (Id [10,20,30])
-- [(0,10),(1,20),(2,30)]
instance (FoldableWithIndex i f) => FoldableWithIndex i (Id f) where
  ifoldMap f (Id x) =
    ifoldMap f x
  {-# INLINE ifoldMap #-}

-- |
-- >>> 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 #-}

instance (NFData (f a)) => NFData (Id f a) where
  rnf (Id x) =
    rnf x
  {-# INLINE rnf #-}

instance (NFData1 f) => NFData1 (Id f) where
  liftRnf f (Id x) =
    liftRnf f x
  {-# INLINE liftRnf #-}

instance (Hashable (f a)) => Hashable (Id f a) where
  hashWithSalt s (Id x) =
    hashWithSalt s x
  {-# INLINE hashWithSalt #-}

instance (Num (f a)) => Num (Id f a) where
  Id x + Id y = Id (x + y)
  {-# INLINE (+) #-}
  Id x * Id y = Id (x * y)
  {-# INLINE (*) #-}
  Id x - Id y = Id (x - y)
  {-# INLINE (-) #-}
  negate (Id x) = Id (negate x)
  {-# INLINE negate #-}
  abs (Id x) = Id (abs x)
  {-# INLINE abs #-}
  signum (Id x) = Id (signum x)
  {-# INLINE signum #-}
  fromInteger = Id . fromInteger
  {-# INLINE fromInteger #-}

instance (Fractional (f a)) => Fractional (Id f a) where
  Id x / Id y = Id (x / y)
  {-# INLINE (/) #-}
  recip (Id x) = Id (recip x)
  {-# INLINE recip #-}
  fromRational = Id . fromRational
  {-# INLINE fromRational #-}

instance (Floating (f a)) => Floating (Id f a) where
  pi = Id pi
  {-# INLINE pi #-}
  exp (Id x) = Id (exp x)
  {-# INLINE exp #-}
  log (Id x) = Id (log x)
  {-# INLINE log #-}
  sqrt (Id x) = Id (sqrt x)
  {-# INLINE sqrt #-}
  Id x ** Id y = Id (x ** y)
  {-# INLINE (**) #-}
  logBase (Id x) (Id y) = Id (logBase x y)
  {-# INLINE logBase #-}
  sin (Id x) = Id (sin x)
  {-# INLINE sin #-}
  cos (Id x) = Id (cos x)
  {-# INLINE cos #-}
  tan (Id x) = Id (tan x)
  {-# INLINE tan #-}
  asin (Id x) = Id (asin x)
  {-# INLINE asin #-}
  acos (Id x) = Id (acos x)
  {-# INLINE acos #-}
  atan (Id x) = Id (atan x)
  {-# INLINE atan #-}
  sinh (Id x) = Id (sinh x)
  {-# INLINE sinh #-}
  cosh (Id x) = Id (cosh x)
  {-# INLINE cosh #-}
  tanh (Id x) = Id (tanh x)
  {-# INLINE tanh #-}
  asinh (Id x) = Id (asinh x)
  {-# INLINE asinh #-}
  acosh (Id x) = Id (acosh x)
  {-# INLINE acosh #-}
  atanh (Id x) = Id (atanh x)
  {-# INLINE atanh #-}

-- |
-- >>> 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 #-}