Add instances for GHC.Tuple.Solo

The `Applicative` instance is the most important one (for
array/vector/sequence indexing purposes), but it deserves
all the usual ones.

T12545 does silly 1% wibbles both ways, it seems, maybe depending
on architecture.

Metric Increase:
    T12545

Metric Decrease:
    T12545

11 files changed, 100 insertions, 1 deletions

diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs
index 96133777be..b54ee66531 100644
--- a/libraries/base/Control/Monad/Fix.hs
+++ b/libraries/base/Control/Monad/Fix.hs
@@ -33,6 +33,7 @@ import Data.Ord ( Down(..) )
 import GHC.Base ( Monad, NonEmpty(..), errorWithoutStackTrace, (.) )
 import GHC.Generics
 import GHC.List ( head, tail )
+import GHC.Tuple (Solo (..))
 import Control.Monad.ST.Imp
 import System.IO
 
@@ -63,6 +64,11 @@ class (Monad m) => MonadFix m where
 
 -- Instances of MonadFix for Prelude monads
 
+-- | @since 4.15
+instance MonadFix Solo where
+    mfix f = let a = f (unSolo a) in a
+             where unSolo (Solo x) = x
+
 -- | @since 2.01
 instance MonadFix Maybe where
     mfix f = let a = f (unJust a) in a
diff --git a/libraries/base/Control/Monad/Zip.hs b/libraries/base/Control/Monad/Zip.hs
index dc192bfc81..36ebeb9985 100644
--- a/libraries/base/Control/Monad/Zip.hs
+++ b/libraries/base/Control/Monad/Zip.hs
@@ -25,6 +25,7 @@ import Data.Ord ( Down(..) )
 import Data.Proxy
 import qualified Data.List.NonEmpty as NE
 import GHC.Generics
+import GHC.Tuple (Solo (..))
 
 -- | Instances should satisfy the laws:
 --
@@ -71,6 +72,11 @@ instance MonadZip Identity where
     mzipWith                 = liftM2
     munzip (Identity (a, b)) = (Identity a, Identity b)
 
+-- | @since 4.15.0.0
+instance MonadZip Solo where
+    mzipWith = liftM2
+    munzip (Solo (a, b)) = (Solo a, Solo b)
+
 -- | @since 4.8.0.0
 instance MonadZip Dual where
     -- Cannot use coerce, it's unsafe
diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs
index 0d4ef944a1..d3a51aa720 100644
--- a/libraries/base/Data/Data.hs
+++ b/libraries/base/Data/Data.hs
@@ -129,6 +129,7 @@ import GHC.List
 import GHC.Num
 import GHC.Read
 import GHC.Show
+import GHC.Tuple (Solo (..))
 import Text.Read( reads )
 
 -- Imports for the instances
@@ -1191,6 +1192,9 @@ deriving instance (Data a, Data b) => Data (Either a b)
 -- | @since 4.0.0.0
 deriving instance Data ()
 
+-- | @since 4.15
+deriving instance Data a => Data (Solo a)
+
 -- | @since 4.0.0.0
 deriving instance (Data a, Data b) => Data (a,b)
 
diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs
index 82fcd874b0..cc7fcefe05 100644
--- a/libraries/base/Data/Foldable.hs
+++ b/libraries/base/Data/Foldable.hs
@@ -114,6 +114,7 @@ import GHC.Arr  ( Array(..), elems, numElements,
                   foldl1Elems, foldr1Elems)
 import GHC.Base hiding ( foldr )
 import GHC.Generics
+import GHC.Tuple (Solo (..))
 import GHC.Num  ( Num(..) )
 
 -- $setup
@@ -747,6 +748,9 @@ instance Foldable (Either a) where
 
     null             = isLeft
 
+-- | @since 4.15
+deriving instance Foldable Solo
+
 -- | @since 4.7.0.0
 instance Foldable ((,) a) where
     foldMap f (_, y) = f y
diff --git a/libraries/base/Data/Functor/Classes.hs b/libraries/base/Data/Functor/Classes.hs
index 965bcdafd8..6a0d008982 100644
--- a/libraries/base/Data/Functor/Classes.hs
+++ b/libraries/base/Data/Functor/Classes.hs
@@ -72,6 +72,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Ord (Down(Down))
 import Data.Complex (Complex((:+)))
 
+import GHC.Tuple (Solo (..))
 import GHC.Read (expectP, list, paren)
 
 import Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec)
@@ -506,14 +507,29 @@ instance Show2 (,) where
     liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
         showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'
 
+-- | @since 4.15
+instance Eq1 Solo where
+  liftEq eq (Solo a) (Solo b) = a `eq` b
+
 -- | @since 4.9.0.0
 instance (Eq a) => Eq1 ((,) a) where
     liftEq = liftEq2 (==)
 
+-- | @since 4.15
+instance Ord1 Solo where
+  liftCompare cmp (Solo a) (Solo b) = cmp a b
+
 -- | @since 4.9.0.0
 instance (Ord a) => Ord1 ((,) a) where
     liftCompare = liftCompare2 compare
 
+-- | @since 4.15
+instance Read1 Solo where
+    liftReadPrec rp _ = readData (readUnaryWith rp "Solo" Solo)
+
+    liftReadListPrec = liftReadListPrecDefault
+    liftReadList     = liftReadListDefault
+
 -- | @since 4.9.0.0
 instance (Read a) => Read1 ((,) a) where
     liftReadPrec = liftReadPrec2 readPrec readListPrec
@@ -521,6 +537,10 @@ instance (Read a) => Read1 ((,) a) where
     liftReadListPrec = liftReadListPrecDefault
     liftReadList     = liftReadListDefault
 
+-- | @since 4.15
+instance Show1 Solo where
+    liftShowsPrec sp _ d (Solo x) = showsUnaryWith sp "Solo" d x
+
 -- | @since 4.9.0.0
 instance (Show a) => Show1 ((,) a) where
     liftShowsPrec = liftShowsPrec2 showsPrec showList
diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs
index 35f2c066b8..d18b0ed98d 100644
--- a/libraries/base/Data/Traversable.hs
+++ b/libraries/base/Data/Traversable.hs
@@ -78,6 +78,7 @@ import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), NonEmpty(..),
                   ($), (.), id, flip )
 import GHC.Generics
 import qualified GHC.List as List ( foldr )
+import GHC.Tuple (Solo (..))
 
 -- $setup
 -- >>> import Prelude
@@ -271,6 +272,9 @@ instance Traversable (Either a) where
     traverse _ (Left x) = pure (Left x)
     traverse f (Right y) = Right <$> f y
 
+-- | @since 4.15
+deriving instance Traversable Solo
+
 -- | @since 4.7.0.0
 instance Traversable ((,) a) where
     traverse f (x, y) = (,) x <$> f y
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index d1fe839cfe..d21226c7c4 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -118,7 +118,7 @@ import GHC.Err
 import GHC.Maybe
 import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
 
-import GHC.Tuple ()              -- Note [Depend on GHC.Tuple]
+import GHC.Tuple (Solo (..))     -- Note [Depend on GHC.Tuple]
 import GHC.Num.Integer ()        -- Note [Depend on GHC.Num.Integer]
 
 -- for 'class Semigroup'
@@ -349,6 +349,15 @@ instance Monoid () where
         mempty        = ()
         mconcat _     = ()
 
+-- | @since 4.15
+instance Semigroup a => Semigroup (Solo a) where
+  Solo a <> Solo b = Solo (a <> b)
+  stimes n (Solo a) = Solo (stimes n a)
+
+-- | @since 4.15
+instance Monoid a => Monoid (Solo a) where
+  mempty = Solo mempty
+
 -- | @since 4.9.0.0
 instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
         (a,b) <> (a',b') = (a<>a',b<>b')
@@ -423,6 +432,20 @@ instance Semigroup a => Semigroup (Maybe a) where
 instance Semigroup a => Monoid (Maybe a) where
     mempty = Nothing
 
+-- | @since 4.15
+instance Applicative Solo where
+  pure = Solo
+
+  -- Note: we really want to match strictly here. This lets us write,
+  -- for example,
+  --
+  -- forceSpine :: Foldable f => f a -> ()
+  -- forceSpine xs
+  --   | Solo r <- traverse_ Solo xs
+  --   = r
+  Solo f <*> Solo x = Solo (f x)
+  liftA2 f (Solo x) (Solo y) = Solo (f x y)
+
 -- | For tuples, the 'Monoid' constraint on @a@ determines
 -- how the first values merge.
 -- For example, 'String's concatenate:
@@ -436,6 +459,10 @@ instance Monoid a => Applicative ((,) a) where
     (u, f) <*> (v, x) = (u <> v, f x)
     liftA2 f (u, x) (v, y) = (u <> v, f x y)
 
+-- | @since 4.15
+instance Monad Solo where
+  Solo x >>= f = f x
+
 -- | @since 4.9.0.0
 instance Monoid a => Monad ((,) a) where
     (u, a) >>= k = case k a of (v, b) -> (u <> v, b)
@@ -982,6 +1009,15 @@ instance Applicative ((->) r) where
 instance Monad ((->) r) where
     f >>= k = \ r -> k (f r) r
 
+-- | @since 4.15
+instance Functor Solo where
+  fmap f (Solo a) = Solo (f a)
+
+  -- Being strict in the `Solo` argument here seems most consistent
+  -- with the concept behind `Solo`: always strict in the wrapper and lazy
+  -- in the contents.
+  x <$ Solo _ = Solo x
+
 -- | @since 2.01
 instance Functor ((,) a) where
     fmap f (x,y) = (x, f y)
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index 09d8fe1bfe..a407d3e771 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -743,6 +743,7 @@ import GHC.Enum    ( Bounded, Enum )
 import GHC.Read    ( Read(..) )
 import GHC.Show    ( Show(..), showString )
 import GHC.Stack.Types ( SrcLoc(..) )
+import GHC.Tuple   (Solo (..))
 import GHC.Unicode ( GeneralCategory(..) )
 import GHC.Fingerprint.Type ( Fingerprint(..) )
 
@@ -1417,6 +1418,9 @@ deriving instance Generic (Proxy t)
 -- | @since 4.6.0.0
 deriving instance Generic ()
 
+-- | @since 4.15
+deriving instance Generic (Solo a)
+
 -- | @since 4.6.0.0
 deriving instance Generic ((,) a b)
 
@@ -1462,6 +1466,9 @@ deriving instance Generic1 (Either a)
 -- | @since 4.6.0.0
 deriving instance Generic1 Proxy
 
+-- | @since 4.15
+deriving instance Generic1 Solo
+
 -- | @since 4.6.0.0
 deriving instance Generic1 ((,) a)
 
diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs
index 1057300c28..7f698ec498 100644
--- a/libraries/base/GHC/Read.hs
+++ b/libraries/base/GHC/Read.hs
@@ -73,6 +73,7 @@ import GHC.Base
 import GHC.Arr
 import GHC.Word
 import GHC.List (filter)
+import GHC.Tuple (Solo (..))
 
 
 -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with
@@ -667,6 +668,9 @@ instance Read () where
   readListPrec = readListPrecDefault
   readList     = readListDefault
 
+-- | @since 4.15
+deriving instance Read a => Read (Solo a)
+
 -- | @since 2.01
 instance (Read a, Read b) => Read (a,b) where
   readPrec = wrap_tup read_tup2
diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs
index 3de7aca723..97d6ad31c7 100644
--- a/libraries/base/GHC/Show.hs
+++ b/libraries/base/GHC/Show.hs
@@ -53,6 +53,7 @@ import GHC.Base
 import GHC.List ((!!), foldr1, break)
 import GHC.Num
 import GHC.Stack.Types
+import GHC.Tuple (Solo (..))
 
 
 -- | The @shows@ functions return a function that prepends the
@@ -167,6 +168,9 @@ appPrec1 = I# 11#       -- appPrec + 1
 -- | @since 2.01
 deriving instance Show ()
 
+-- | @since 4.15
+deriving instance Show a => Show (Solo a)
+
 -- | @since 2.01
 instance Show a => Show [a]  where
   {-# SPECIALISE instance Show [String] #-}
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 0525eefc2e..7ba14bf36b 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -11,6 +11,10 @@
   * Add `Semigroup` and `Monoid` instances for `Data.Functor.Product` and
     `Data.Functor.Compose`.
 
+  * Add `Functor`, `Applicative`, `Monad`, `MonadFix`, `Foldable`, `Traversable`,
+    `Eq`, `Ord`, `Show`, `Read`, `Eq1`, `Ord1`, `Show1`, `Read1`, `Generic`,
+    `Generic1`, and `Data` instances for `GHC.Tuple.Solo`.
+
   * Add `Eq1`, `Read1` and `Show1` instance for `Complex`;
     add `Eq1/2`, `Ord1/2`, `Show1/2` and `Read1/2` instances for 3 and 4-tuples.