Add `Alternative` wrapper to Data.Monoid

Complete #9759. Use `coerce` to get nicer definitions of `Sum` and
`Product`; update documentation for `First` and `Last`.

Reviewed By: hvr

Differential Revision: https://phabricator.haskell.org/D422

2 files changed, 33 insertions, 29 deletions

diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs
index 8b8c8e80b7..57ff498263 100644
--- a/libraries/base/Data/Monoid.hs
+++ b/libraries/base/Data/Monoid.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -36,7 +37,9 @@ module Data.Monoid (
         -- * Maybe wrappers
         -- $MaybeExamples
         First(..),
-        Last(..)
+        Last(..),
+        -- * 'Alternative' wrapper
+        Alt (..)
   ) where
 
 -- Push down the module in the dependency hierarchy.
@@ -102,7 +105,8 @@ newtype Sum a = Sum { getSum :: a }
 
 instance Num a => Monoid (Sum a) where
         mempty = Sum 0
-        Sum x `mappend` Sum y = Sum (x + y)
+        mappend = coerce ((+) :: a -> a -> a)
+--        Sum x `mappend` Sum y = Sum (x + y)
 
 -- | Monoid under multiplication.
 newtype Product a = Product { getProduct :: a }
@@ -110,7 +114,8 @@ newtype Product a = Product { getProduct :: a }
 
 instance Num a => Monoid (Product a) where
         mempty = Product 1
-        Product x `mappend` Product y = Product (x * y)
+        mappend = coerce ((*) :: a -> a -> a)
+--        Product x `mappend` Product y = Product (x * y)
 
 -- $MaybeExamples
 -- To implement @find@ or @findLast@ on any 'Foldable':
@@ -145,44 +150,41 @@ instance Num a => Monoid (Product a) where
 
 
 -- | Maybe monoid returning the leftmost non-Nothing value.
+--
+-- @'First' a@ is isomorphic to @'Alt' 'Maybe' a@, but precedes it
+-- historically.
 newtype First a = First { getFirst :: Maybe a }
-        deriving (Eq, Ord, Read, Show, Generic, Generic1)
+        deriving (Eq, Ord, Read, Show, Generic, Generic1,
+                  Functor, Applicative, Monad)
 
 instance Monoid (First a) where
         mempty = First Nothing
-        r@(First (Just _)) `mappend` _ = r
         First Nothing `mappend` r = r
-
-instance Functor First where
-        fmap f (First x) = First (fmap f x)
-
-instance Applicative First where
-        pure x = First (Just x)
-        First x <*> First y = First (x <*> y)
-
-instance Monad First where
-        return x = First (Just x)
-        First x >>= m = First (x >>= getFirst . m)
+        l `mappend` _             = l
 
 -- | Maybe monoid returning the rightmost non-Nothing value.
+--
+-- @'Last' a@ is isomorphic to @'Dual' ('First' a)@, and thus to
+-- @'Dual' ('Alt' 'Maybe' a)@
 newtype Last a = Last { getLast :: Maybe a }
-        deriving (Eq, Ord, Read, Show, Generic, Generic1)
+        deriving (Eq, Ord, Read, Show, Generic, Generic1,
+                  Functor, Applicative, Monad)
 
 instance Monoid (Last a) where
         mempty = Last Nothing
-        _ `mappend` r@(Last (Just _)) = r
-        r `mappend` Last Nothing = r
-
-instance Functor Last where
-        fmap f (Last x) = Last (fmap f x)
+        l `mappend` Last Nothing = l
+        _ `mappend` r            = r
 
-instance Applicative Last where
-        pure x = Last (Just x)
-        Last x <*> Last y = Last (x <*> y)
-
-instance Monad Last where
-        return x = Last (Just x)
-        Last x >>= m = Last (x >>= getLast . m)
+-- | Monoid under '<|>'.
+--
+-- /Since: 4.8.0.0/
+newtype Alt f a = Alt {getAlt :: f a}
+  deriving (Generic, Generic1, Read, Show, Eq, Ord, Num, Enum,
+            Monad, MonadPlus, Applicative, Alternative, Functor)
+
+instance forall f a . Alternative f => Monoid (Alt f a) where
+        mempty = Alt empty
+        mappend = coerce ((<|>) :: f a -> f a -> f a)
 
 {-
 {--------------------------------------------------------------------
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 0f892494c3..c3e1fa7240 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -89,6 +89,8 @@
 
   * Update Unicode class definitions to Unicode version 7.0
 
+  * Add `Alt`, an `Alternative` wrapper, to `Data.Monoid`. (#9759)
+
 ## 4.7.0.1  *Jul 2014*
 
   * Bundled with GHC 7.8.3