Id.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall -Werror #-}

-- |
-- @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,
    idTagged,
    idProxy,
    just,
    rejust,
    nothing,
    renothing,
  )
where

import Control.Applicative (Alternative (empty, (<|>)))
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.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 (..),
    Read1 (..),
    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))
import Data.Functor.Plus (Plus (..))
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, Read, 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

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

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

-- |
-- >>> liftReadsPrec readsPrec readList 0 "Id [1,2,3]" :: [(Id [] Int, String)]
-- [(Id [1,2,3],"")]
--
-- >>> liftReadsPrec readsPrec readList 0 "Id (Just 'x')" :: [(Id Maybe Char, String)]
-- [(Id (Just 'x'),"")]
--
-- >>> liftReadsPrec readsPrec readList 11 "(Id [1,2,3])" :: [(Id [] Int, String)]
-- [(Id [1,2,3],"")]
instance (Read1 f) => Read1 (Id f) where
  liftReadsPrec rp rl d =
    readParen
      (d > 10)
      (\s -> [(Id x, t) | ("Id", r) <- lex s, (x, t) <- liftReadsPrec rp rl 11 r])

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

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

-- |
-- >>> 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)

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

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

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

instance GetterId (Identity a) Identity a where
  getId =
    to Id

instance GetterId (Maybe a) Maybe a where
  getId =
    to Id

instance GetterId [a] [] a where
  getId =
    to Id

instance GetterId (NonEmpty a) NonEmpty a where
  getId =
    to Id

instance GetterId (Either e a) (Either e) a where
  getId =
    to Id

instance GetterId (w, a) ((,) w) a where
  getId =
    to Id

instance GetterId (Const c a) (Const c) a where
  getId =
    to Id

instance GetterId (Proxy a) Proxy a where
  getId =
    to Id

instance GetterId (Tagged s a) (Tagged s) a where
  getId =
    to Id

-- |
-- >>> 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)

instance HasId (Id f a) f a where
  setId =
    const

instance HasId (Identity a) Identity a where
  setId =
    const . unId

instance HasId (Maybe a) Maybe a where
  setId =
    const . unId

instance HasId [a] [] a where
  setId =
    const . unId

instance HasId (NonEmpty a) NonEmpty a where
  setId =
    const . unId

instance HasId (Either e a) (Either e) a where
  setId =
    const . unId

instance HasId (w, a) ((,) w) a where
  setId =
    const . unId

instance HasId (Const c a) (Const c) a where
  setId =
    const . unId

instance HasId (Proxy a) Proxy a where
  setId =
    const . unId

instance HasId (Tagged s a) (Tagged s) a where
  setId =
    const . unId

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

instance ReviewId (Identity a) Identity a where
  reviewId =
    unto unId

instance ReviewId (Maybe a) Maybe a where
  reviewId =
    unto unId

instance ReviewId [a] [] a where
  reviewId =
    unto unId

instance ReviewId (NonEmpty a) NonEmpty a where
  reviewId =
    unto unId

instance ReviewId (Either e a) (Either e) a where
  reviewId =
    unto unId

instance ReviewId (w, a) ((,) w) a where
  reviewId =
    unto unId

instance ReviewId (Const c a) (Const c) a where
  reviewId =
    unto unId

instance ReviewId (Proxy a) Proxy a where
  reviewId =
    unto unId

instance ReviewId (Tagged s a) (Tagged s) a where
  reviewId =
    unto unId

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

instance AsId (Id f a) f a where
  matchId =
    Just

instance AsId (Identity a) Identity a where
  matchId =
    Just . Id

instance AsId (Maybe a) Maybe a where
  matchId =
    Just . Id

instance AsId [a] [] a where
  matchId =
    Just . Id

instance AsId (NonEmpty a) NonEmpty a where
  matchId =
    Just . Id

instance AsId (Either e a) (Either e) a where
  matchId =
    Just . Id

instance AsId (w, a) ((,) w) a where
  matchId =
    Just . Id

instance AsId (Const c a) (Const c) a where
  matchId =
    Just . Id

instance AsId (Proxy a) Proxy a where
  matchId =
    Just . Id

instance AsId (Tagged s a) (Tagged s) a where
  matchId =
    Just . Id

-- |
-- >>> 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)

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

-- |
-- >>> 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 =
    over _Wrapped . 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)

-- |
-- >>> 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)
  pure =
    Id . pure
  liftA2 f (Id x) (Id y) =
    Id (liftA2 f x y)
  Id x *> Id y =
    Id (x *> y)
  Id x <* Id y =
    Id (x <* y)

-- |
-- >>> 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)

-- |
-- >>> 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)

-- |
-- >>> 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)
  empty =
    Id 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)

-- |
-- >>> 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)

-- |
-- >>> 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
  foldr f z (Id x) =
    foldr f z x
  null (Id x) =
    null x
  length (Id x) =
    length x

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

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

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

-- |
-- >>> unId (liftIO (pure 7) :: Id IO Int)
-- 7
instance (MonadIO f) => MonadIO (Id f) where
  liftIO =
    Id . 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

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

-- |
-- >>> 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
  catchError (Id x) f =
    Id (catchError x (view _Wrapped . f))

-- |
-- >>> 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))))

-- |
-- >>> 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
  local f (Id x) =
    Id (local f x)
  reader =
    Id . 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)
  tell =
    Id . tell
  listen =
    over _Wrapped listen
  pass =
    over _Wrapped 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
  put =
    Id . put
  state =
    Id . 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))

-- |
-- >>> fail "oops" :: Id Maybe Int
-- Id Nothing
instance (MonadFail f) => MonadFail (Id f) where
  fail =
    Id . 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)

-- |
-- >>> 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)

-- |
-- >>> 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)
  conquer =
    Id 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)
  lose f =
    Id (lose f)

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

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

-- |
-- >>> 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)

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

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

-- |
-- >>> 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))

-- |
-- >>> 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))

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

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

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

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