summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/base/Control/Monad/Fix.hs18
-rw-r--r--libraries/base/Data/Data.hs113
-rw-r--r--libraries/base/Data/Foldable.hs60
-rw-r--r--libraries/base/Data/Monoid.hs33
-rw-r--r--libraries/base/Data/Traversable.hs16
-rw-r--r--testsuite/tests/annotations/should_fail/annfail10.stderr25
-rw-r--r--testsuite/tests/ghci.debugger/scripts/break006.stderr22
-rw-r--r--testsuite/tests/typecheck/should_fail/T5095.stderr15
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)
View Lorry Controller Status