Switch to Solo from Identity'

* The `Identity'` type was non-standard and overly complicated.  The
  `Solo` type, now in `base`, is operationally identical and simpler to
  deal with. Use that instead.

* Remove some surprisingly lazy matches on `Identity'`.

optics-core/optics-core.cabal

@@ -77,6 +77,7 @@ library
                , indexed-profunctors    >= 0.1        && <0.2
                , transformers           >= 0.5        && <0.7
                , indexed-traversable    >= 0.1        && <0.2
+               , OneTuple               >= 0.3        && <0.4
 
   exposed-modules: Optics.Core
 

optics-core/src/Optics/Internal/Utils.hs

@@ -3,9 +3,9 @@
 -- | This module is intended for internal use only, and may change without warning
 -- in subsequent releases.
 module Optics.Internal.Utils
-  ( Identity'(..)
-  , wrapIdentity'
-  , unwrapIdentity'
+  ( Solo (..)
+  , wrapSolo'
+  , getSolo
 
   , Traversed(..)
   , runTraversed
@@ -21,27 +21,22 @@ module Optics.Internal.Utils
 import qualified Data.Semigroup as SG
 
 import Data.Profunctor.Indexed
+import Data.Tuple.Solo (Solo (..), getSolo)
 
 -- Needed for strict application of (indexed) setters.
 --
 -- Credit for this goes to Eric Mertens, see
 -- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.
-data Identity' a = Identity' {-# UNPACK #-} !() a
-  deriving Functor
-
-instance Applicative Identity' where
-  pure a = Identity' () a
-  Identity' () f <*> Identity' () x = Identity' () (f x)
 
-instance Mapping (Star Identity') where
-  roam  f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k)
-  iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k)
+instance Mapping (Star Solo) where
+  roam  f (Star k) = Star $ wrapSolo' . f (getSolo . k)
+  iroam f (Star k) = Star $ wrapSolo' . f (\_ -> getSolo . k)
 
-instance Mapping (IxStar Identity') where
+instance Mapping (IxStar Solo) where
   roam  f (IxStar k) =
-    IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i)
+    IxStar $ \i -> wrapSolo' . f (getSolo . k i)
   iroam f (IxStar k) =
-    IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i))
+    IxStar $ \ij -> wrapSolo' . f (\i -> getSolo . k (ij i))
 
 -- | Mark a value for evaluation to whnf.
 --
@@ -50,11 +45,8 @@ instance Mapping (IxStar Identity') where
 -- instance of Identity' makes sure that we force evaluation of all of them, but
 -- we leave anything else alone.
 --
-wrapIdentity' :: a -> Identity' a
-wrapIdentity' a = Identity' (a `seq` ()) a
-
-unwrapIdentity' :: Identity' a -> a
-unwrapIdentity' (Identity' () a) = a
+wrapSolo' :: a -> Solo a
+wrapSolo' a = Solo $! a
 
 ----------------------------------------
 

optics-core/src/Optics/IxSetter.hs

@@ -85,8 +85,8 @@ iover'
   => Optic k is s t a b
   -> (i -> a -> b) -> s -> t
 iover' o = \f ->
-  let star = getOptic (castOptic @A_Setter o) $ IxStar (\i -> wrapIdentity' . f i)
-  in unwrapIdentity' . runIxStar star id
+  let star = getOptic (castOptic @A_Setter o) $ IxStar (\i -> wrapSolo' . f i)
+  in getSolo . runIxStar star id
 
 {-# INLINE iover' #-}
 

optics-core/src/Optics/IxTraversal.hs

@@ -227,9 +227,9 @@ ifailover'
   => Optic k is s t a b
   -> (i -> a -> b) -> s -> Maybe t
 ifailover' o = \f s ->
-  let OrT visited t = itraverseOf o (\i -> wrapOrT . wrapIdentity' . f i) s
+  let OrT visited t = itraverseOf o (\i -> wrapOrT . wrapSolo' . f i) s
   in if visited
-     then Just (unwrapIdentity' t)
+     then case t of Solo v -> Just v
      else Nothing
 {-# INLINE ifailover' #-}
 

optics-core/src/Optics/Setter.hs

@@ -106,8 +106,8 @@ over'
   => Optic k is s t a b
   -> (a -> b) -> s -> t
 over' o = \f ->
-  let star = getOptic (castOptic @A_Setter o) $ Star (wrapIdentity' . f)
-  in unwrapIdentity' . runStar star
+  let star = getOptic (castOptic @A_Setter o) $ Star (wrapSolo' . f)
+  in getSolo . runStar star
 {-# INLINE over' #-}
 
 -- | Apply a setter.

optics-core/src/Optics/Traversal.hs

@@ -305,9 +305,9 @@ failover'
   => Optic k is s t a b
   -> (a -> b) -> s -> Maybe t
 failover' o = \f s ->
-  let OrT visited t = traverseOf o (wrapOrT . wrapIdentity' . f) s
+  let OrT visited t = traverseOf o (wrapOrT . wrapSolo' . f) s
   in if visited
-     then Just (unwrapIdentity' t)
+     then case t of Solo v -> Just v
      else Nothing
 {-# INLINE failover' #-}