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

5 files changed, 239 insertions, 1 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