Add various instances to newtypes in Data.Monoid

Summary:
Add Functor instances for Dual, Sum and Product
Add Foldable instances for Dual, Sum and Product
Add Traversable instances for Dual, Sum and Product
Add Foldable and Traversable instances for First and Last
Add Applicative, Monad instances to Dual, Sum, Product
Add MonadFix to Data.Monoid wrappers
Derive Data for Identity
Add Data instances to Data.Monoid wrappers
Add Data (Alt f a) instance

Reviewers: ekmett, dfeuer, hvr, austin

Reviewed By: dfeuer, austin

Subscribers: thomie

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

GHC Trac Issues: #10107

8 files changed, 281 insertions, 21 deletions

diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs
index 76faeaf655..ef8eeee776 100644
--- a/libraries/base/Control/Monad/Fix.hs
+++ b/libraries/base/Control/Monad/Fix.hs
@@ -26,6 +26,7 @@ module Control.Monad.Fix (
 import Data.Either
 import Data.Function ( fix )
 import Data.Maybe
+import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) )
 import GHC.Base ( Monad, error, (.) )
 import GHC.List ( head, tail )
 import GHC.ST
@@ -81,3 +82,20 @@ instance MonadFix (Either e) where
 
 instance MonadFix (ST s) where
         mfix = fixST
+
+-- Instances of Data.Monoid wrappers
+
+instance MonadFix Dual where
+    mfix f   = Dual (fix (getDual . f))
+
+instance MonadFix Sum where
+    mfix f   = Sum (fix (getSum . f))
+
+instance MonadFix Product where
+    mfix f   = Product (fix (getProduct . f))
+
+instance MonadFix First where
+    mfix f   = First (mfix (getFirst . f))
+
+instance MonadFix Last where
+    mfix f   = Last (mfix (getLast . f))
diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs
index 6961b250b5..34c235021e 100644
--- a/libraries/base/Data/Data.hs
+++ b/libraries/base/Data/Data.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE RankNTypes, ScopedTypeVariables, PolyKinds, StandaloneDeriving,
              AutoDeriveTypeable, TypeOperators, GADTs, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -----------------------------------------------------------------------------
@@ -109,10 +110,11 @@ module Data.Data (
 import Data.Either
 import Data.Eq
 import Data.Maybe
+import Data.Monoid
 import Data.Ord
 import Data.Typeable
 import Data.Version( Version(..) )
-import GHC.Base
+import GHC.Base hiding (Any)
 import GHC.List
 import GHC.Num
 import GHC.Read
@@ -1398,3 +1400,112 @@ instance Data Version where
                     1 -> k (k (z Version))
                     _ -> error "Data.Data.gunfold(Version)"
   dataTypeOf _  = versionDataType
+
+-----------------------------------------------------------------------
+-- instances for Data.Monoid wrappers
+
+dualConstr :: Constr
+dualConstr = mkConstr dualDataType "Dual" ["getDual"] Prefix
+
+dualDataType :: DataType
+dualDataType = mkDataType "Data.Monoid.Dual" [dualConstr]
+
+instance Data a => Data (Dual a) where
+  gfoldl f z (Dual x) = z Dual `f` x
+  gunfold k z _ = k (z Dual)
+  toConstr (Dual _) = dualConstr
+  dataTypeOf _ = dualDataType
+  dataCast1 f = gcast1 f
+
+allConstr :: Constr
+allConstr = mkConstr allDataType "All" ["getAll"] Prefix
+
+allDataType :: DataType
+allDataType = mkDataType "All" [allConstr]
+
+instance Data All where
+  gfoldl f z (All x) = (z All `f` x)
+  gunfold k z _ = k (z All)
+  toConstr (All _) = allConstr
+  dataTypeOf _ = allDataType
+
+anyConstr :: Constr
+anyConstr = mkConstr anyDataType "Any" ["getAny"] Prefix
+
+anyDataType :: DataType
+anyDataType = mkDataType "Any" [anyConstr]
+
+instance Data Any where
+  gfoldl f z (Any x) = (z Any `f` x)
+  gunfold k z _ = k (z Any)
+  toConstr (Any _) = anyConstr
+  dataTypeOf _ = anyDataType
+
+
+sumConstr :: Constr
+sumConstr = mkConstr sumDataType "Sum" ["getSum"] Prefix
+
+sumDataType :: DataType
+sumDataType = mkDataType "Data.Monoid.Sum" [sumConstr]
+
+instance Data a => Data (Sum a) where
+  gfoldl f z (Sum x) = z Sum `f` x
+  gunfold k z _ = k (z Sum)
+  toConstr (Sum _) = sumConstr
+  dataTypeOf _ = sumDataType
+  dataCast1 f = gcast1 f
+
+
+productConstr :: Constr
+productConstr = mkConstr productDataType "Product" ["getProduct"] Prefix
+
+productDataType :: DataType
+productDataType = mkDataType "Data.Monoid.Product" [productConstr]
+
+instance Data a => Data (Product a) where
+  gfoldl f z (Product x) = z Product `f` x
+  gunfold k z _ = k (z Product)
+  toConstr (Product _) = productConstr
+  dataTypeOf _ = productDataType
+  dataCast1 f = gcast1 f
+
+
+firstConstr :: Constr
+firstConstr = mkConstr firstDataType "First" ["getFirst"] Prefix
+
+firstDataType :: DataType
+firstDataType = mkDataType "Data.Monoid.First" [firstConstr]
+
+instance Data a => Data (First a) where
+  gfoldl f z (First x) = (z First `f` x)
+  gunfold k z _ = k (z First)
+  toConstr (First _) = firstConstr
+  dataTypeOf _ = firstDataType
+  dataCast1 f = gcast1 f
+
+
+lastConstr :: Constr
+lastConstr = mkConstr lastDataType "Last" ["getLast"] Prefix
+
+lastDataType :: DataType
+lastDataType = mkDataType "Data.Monoid.Last" [lastConstr]
+
+instance Data a => Data (Last a) where
+  gfoldl f z (Last x) = (z Last `f` x)
+  gunfold k z _ = k (z Last)
+  toConstr (Last _) = lastConstr
+  dataTypeOf _ = lastDataType
+  dataCast1 f = gcast1 f
+
+
+altConstr :: Constr
+altConstr = mkConstr altDataType "Alt" ["getAlt"] Prefix
+
+altDataType :: DataType
+altDataType = mkDataType "Alt" [altConstr]
+
+instance (Data (f a), Typeable f, Typeable a) => Data (Alt f a) where
+  gfoldl f z (Alt x) = (z Alt `f` x)
+  gunfold k z _ = k (z Alt)
+  toConstr (Alt _) = altConstr
+  dataTypeOf _ = altDataType
diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs
index a745f66092..1f20261943 100644
--- a/libraries/base/Data/Foldable.hs
+++ b/libraries/base/Data/Foldable.hs
@@ -282,6 +282,66 @@ instance Foldable Proxy where
     sum _      = 0
     product _  = 1
 
+instance Foldable Dual where
+    foldMap            = coerce
+
+    elem               = (. getDual) #. (==)
+    foldl              = coerce
+    foldl'             = coerce
+    foldl1 _           = getDual
+    foldr f z (Dual x) = f x z
+    foldr'             = foldr
+    foldr1 _           = getDual
+    length _           = 1
+    maximum            = getDual
+    minimum            = getDual
+    null _             = False
+    product            = getDual
+    sum                = getDual
+    toList (Dual x)    = [x]
+
+instance Foldable Sum where
+    foldMap            = coerce
+
+    elem               = (. getSum) #. (==)
+    foldl              = coerce
+    foldl'             = coerce
+    foldl1 _           = getSum
+    foldr f z (Sum x)  = f x z
+    foldr'             = foldr
+    foldr1 _           = getSum
+    length _           = 1
+    maximum            = getSum
+    minimum            = getSum
+    null _             = False
+    product            = getSum
+    sum                = getSum
+    toList (Sum x)     = [x]
+
+instance Foldable Product where
+    foldMap               = coerce
+
+    elem                  = (. getProduct) #. (==)
+    foldl                 = coerce
+    foldl'                = coerce
+    foldl1 _              = getProduct
+    foldr f z (Product x) = f x z
+    foldr'                = foldr
+    foldr1 _              = getProduct
+    length _              = 1
+    maximum               = getProduct
+    minimum               = getProduct
+    null _                = False
+    product               = getProduct
+    sum                   = getProduct
+    toList (Product x)    = [x]
+
+instance Foldable First where
+    foldMap f = foldMap f . getFirst
+
+instance Foldable Last where
+    foldMap f = foldMap f . getLast
+
 -- We don't export Max and Min because, as Edward Kmett pointed out to me,
 -- there are two reasonable ways to define them. One way is to use Maybe, as we
 -- do here; the other way is to impose a Bounded constraint on the Monoid
diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs
index dbabaff981..82c01603ca 100644
--- a/libraries/base/Data/Monoid.hs
+++ b/libraries/base/Data/Monoid.hs
@@ -75,6 +75,17 @@ instance Monoid a => Monoid (Dual a) where
         mempty = Dual mempty
         Dual x `mappend` Dual y = Dual (y `mappend` x)
 
+instance Functor Dual where
+    fmap     = coerce
+
+instance Applicative Dual where
+    pure     = Dual
+    (<*>)    = coerce
+
+instance Monad Dual where
+    return   = Dual
+    m >>= k  = k (getDual m)
+
 -- | The monoid of endomorphisms under composition.
 newtype Endo a = Endo { appEndo :: a -> a }
                deriving (Generic)
@@ -108,6 +119,17 @@ instance Num a => Monoid (Sum a) where
         mappend = coerce ((+) :: a -> a -> a)
 --        Sum x `mappend` Sum y = Sum (x + y)
 
+instance Functor Sum where
+    fmap     = coerce
+
+instance Applicative Sum where
+    pure     = Sum
+    (<*>)    = coerce
+
+instance Monad Sum where
+    return   = Sum
+    m >>= k  = k (getSum m)
+
 -- | Monoid under multiplication.
 newtype Product a = Product { getProduct :: a }
         deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1, Num)
@@ -117,6 +139,17 @@ instance Num a => Monoid (Product a) where
         mappend = coerce ((*) :: a -> a -> a)
 --        Product x `mappend` Product y = Product (x * y)
 
+instance Functor Product where
+    fmap     = coerce
+
+instance Applicative Product where
+    pure     = Product
+    (<*>)    = coerce
+
+instance Monad Product where
+    return   = Product
+    m >>= k  = k (getProduct m)
+
 -- $MaybeExamples
 -- To implement @find@ or @findLast@ on any 'Foldable':
 --
diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs
index e7caf4e2d6..aaea44b23a 100644
--- a/libraries/base/Data/Traversable.hs
+++ b/libraries/base/Data/Traversable.hs
@@ -50,6 +50,7 @@ import Control.Applicative ( Const(..) )
 import Data.Either ( Either(..) )
 import Data.Foldable ( Foldable )
 import Data.Functor
+import Data.Monoid ( Dual(..), Sum(..), Product(..), First(..), Last(..) )
 import Data.Proxy ( Proxy(..) )
 
 import GHC.Arr
@@ -205,6 +206,21 @@ instance Traversable Proxy where
 instance Traversable (Const m) where
     traverse _ (Const m) = pure $ Const m
 
+instance Traversable Dual where
+    traverse f (Dual x) = Dual <$> f x
+
+instance Traversable Sum where
+    traverse f (Sum x) = Sum <$> f x
+
+instance Traversable Product where
+    traverse f (Product x) = Product <$> f x
+
+instance Traversable First where
+    traverse f (First x) = First <$> traverse f x
+
+instance Traversable Last where
+    traverse f (Last x) = Last <$> traverse f x
+
 -- general functions
 
 -- | 'for' is 'traverse' with its arguments flipped. For a version
diff --git a/testsuite/tests/annotations/should_fail/annfail10.stderr b/testsuite/tests/annotations/should_fail/annfail10.stderr
index baddbbd035..262677b7f8 100644
--- a/testsuite/tests/annotations/should_fail/annfail10.stderr
+++ b/testsuite/tests/annotations/should_fail/annfail10.stderr
@@ -6,21 +6,26 @@ annfail10.hs:9:1:
       instance (Data.Data.Data a, Data.Data.Data b) =>
                Data.Data.Data (Either a b)
         -- Defined in ‘Data.Data’
-      instance Data.Data.Data t => Data.Data.Data (Data.Proxy.Proxy t)
+      instance Data.Data.Data Data.Monoid.All -- Defined in ‘Data.Data’
+      instance forall (k :: BOX) (f :: k -> *) (a :: k).
+               (Data.Data.Data (f a), Data.Typeable.Internal.Typeable f,
+                Data.Typeable.Internal.Typeable a) =>
+               Data.Data.Data (Data.Monoid.Alt f a)
         -- Defined in ‘Data.Data’
-      instance (GHC.Types.Coercible a b, Data.Data.Data a,
-                Data.Data.Data b) =>
-               Data.Data.Data (Data.Type.Coercion.Coercion a b)
-        -- Defined in ‘Data.Data’
-      ...plus 31 others
+      ...plus 39 others
     In the annotation: {-# ANN f 1 #-}
 
 annfail10.hs:9:11:
     No instance for (Num a0) arising from the literal ‘1’
     The type variable ‘a0’ is ambiguous
     Note: there are several potential instances:
-      instance Num GHC.Int.Int16 -- Defined in ‘GHC.Int’
-      instance Num GHC.Int.Int32 -- Defined in ‘GHC.Int’
-      instance Num GHC.Int.Int64 -- Defined in ‘GHC.Int’
-      ...plus 11 others
+      instance forall (k :: BOX) (f :: k -> *) (a :: k).
+               Num (f a) =>
+               Num (Data.Monoid.Alt f a)
+        -- Defined in ‘Data.Monoid’
+      instance Num a => Num (Data.Monoid.Product a)
+        -- Defined in ‘Data.Monoid’
+      instance Num a => Num (Data.Monoid.Sum a)
+        -- Defined in ‘Data.Monoid’
+      ...plus 14 others
     In the annotation: {-# ANN f 1 #-}
diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr
index 5084150660..865860564d 100644
--- a/testsuite/tests/ghci.debugger/scripts/break006.stderr
+++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr
@@ -7,11 +7,12 @@
     Note: there are several potential instances:
       instance (Show a, Show b) => Show (Either a b)
         -- Defined in ‘Data.Either’
-      instance forall (k :: BOX) (s :: k). Show (Data.Proxy.Proxy s)
-        -- Defined in ‘Data.Proxy’
-      instance (GHC.Arr.Ix a, Show a, Show b) => Show (GHC.Arr.Array a b)
-        -- Defined in ‘GHC.Arr’
-      ...plus 25 others
+      instance Show Data.Monoid.All -- Defined in ‘Data.Monoid’
+      instance forall (k :: BOX) (f :: k -> *) (a :: k).
+               Show (f a) =>
+               Show (Data.Monoid.Alt f a)
+        -- Defined in ‘Data.Monoid’
+      ...plus 33 others
     In a stmt of an interactive GHCi command: print it
 
 <interactive>:8:1:
@@ -22,9 +23,10 @@
     Note: there are several potential instances:
       instance (Show a, Show b) => Show (Either a b)
         -- Defined in ‘Data.Either’
-      instance forall (k :: BOX) (s :: k). Show (Data.Proxy.Proxy s)
-        -- Defined in ‘Data.Proxy’
-      instance (GHC.Arr.Ix a, Show a, Show b) => Show (GHC.Arr.Array a b)
-        -- Defined in ‘GHC.Arr’
-      ...plus 25 others
+      instance Show Data.Monoid.All -- Defined in ‘Data.Monoid’
+      instance forall (k :: BOX) (f :: k -> *) (a :: k).
+               Show (f a) =>
+               Show (Data.Monoid.Alt f a)
+        -- Defined in ‘Data.Monoid’
+      ...plus 33 others
     In a stmt of an interactive GHCi command: print it
diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr
index af420d2382..e0f9336e01 100644
--- a/testsuite/tests/typecheck/should_fail/T5095.stderr
+++ b/testsuite/tests/typecheck/should_fail/T5095.stderr
@@ -60,6 +60,21 @@ T5095.hs:9:11:
         -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’
       instance Eq Integer
         -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’
+      instance Eq Data.Monoid.All -- Defined in ‘Data.Monoid’
+      instance forall (k :: BOX) (f :: k -> *) (a :: k).
+               Eq (f a) =>
+               Eq (Data.Monoid.Alt f a)
+        -- Defined in ‘Data.Monoid’
+      instance Eq Data.Monoid.Any -- Defined in ‘Data.Monoid’
+      instance Eq a => Eq (Data.Monoid.Dual a)
+        -- Defined in ‘Data.Monoid’
+      instance Eq a => Eq (Data.Monoid.First a)
+        -- Defined in ‘Data.Monoid’
+      instance Eq a => Eq (Data.Monoid.Last a)
+        -- Defined in ‘Data.Monoid’
+      instance Eq a => Eq (Data.Monoid.Product a)
+        -- Defined in ‘Data.Monoid’
+      instance Eq a => Eq (Data.Monoid.Sum a) -- Defined in ‘Data.Monoid’
       instance forall (k :: BOX) (s :: k). Eq (Data.Proxy.Proxy s)
         -- Defined in ‘Data.Proxy’
       instance (Eq a, Eq b) => Eq (Either a b)