summaryrefslogtreecommitdiff
path: root/libraries
diff options
context:
space:
mode:
authorRyanGlScott <ryan.gl.scott@gmail.com>2016-02-25 14:49:48 +0100
committerBen Gamari <ben@smart-cactus.org>2016-02-25 15:41:55 +0100
commit673efccb3b348e9daf23d9e65460691bbea8586e (patch)
tree825b41d829a0e032a2db18386edd5a39036c2dc2 /libraries
parent6319a8cf79cc1f1e25220113149ab48e5083321b (diff)
downloadhaskell-673efccb3b348e9daf23d9e65460691bbea8586e.tar.gz
Add more type class instances for GHC.Generics
GHC.Generics provides several representation data types that have obvious instances of various type classes in base, along with various other types of meta-data (such as associativity and fixity). Specifically, instances have been added for the following type classes (where possible): - Applicative - Data - Functor - Monad - MonadFix - MonadPlus - MonadZip - Foldable - Traversable - Enum - Bounded - Ix - Generic1 Thanks to ocharles for starting this! Test Plan: Validate Reviewers: ekmett, austin, hvr, bgamari Reviewed By: bgamari Subscribers: RyanGlScott, thomie Differential Revision: https://phabricator.haskell.org/D1937 GHC Trac Issues: #9043
Diffstat (limited to 'libraries')
-rw-r--r--libraries/base/Control/Monad/Fix.hs18
-rw-r--r--libraries/base/Control/Monad/Zip.hs15
-rw-r--r--libraries/base/Data/Bifunctor.hs4
-rw-r--r--libraries/base/Data/Data.hs309
-rw-r--r--libraries/base/Data/Foldable.hs24
-rw-r--r--libraries/base/Data/Traversable.hs24
-rw-r--r--libraries/base/GHC/Generics.hs124
-rw-r--r--libraries/base/changelog.md5
8 files changed, 497 insertions, 26 deletions
diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs
index 6b78e90c89..4862770f26 100644
--- a/libraries/base/Control/Monad/Fix.hs
+++ b/libraries/base/Control/Monad/Fix.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
@@ -29,6 +30,7 @@ import Data.Maybe
import Data.Monoid ( Dual(..), Sum(..), Product(..)
, First(..), Last(..), Alt(..) )
import GHC.Base ( Monad, errorWithoutStackTrace, (.) )
+import GHC.Generics
import GHC.List ( head, tail )
import GHC.ST
import System.IO
@@ -103,3 +105,19 @@ instance MonadFix Last where
instance MonadFix f => MonadFix (Alt f) where
mfix f = Alt (mfix (getAlt . f))
+
+-- Instances for GHC.Generics
+instance MonadFix Par1 where
+ mfix f = Par1 (fix (unPar1 . f))
+
+instance MonadFix f => MonadFix (Rec1 f) where
+ mfix f = Rec1 (mfix (unRec1 . f))
+
+instance MonadFix f => MonadFix (M1 i c f) where
+ mfix f = M1 (mfix (unM1. f))
+
+instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where
+ mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f))
+ where
+ fstP (a :*: _) = a
+ sndP (_ :*: b) = b
diff --git a/libraries/base/Control/Monad/Zip.hs b/libraries/base/Control/Monad/Zip.hs
index 1f63cab3d7..771b8aa9c6 100644
--- a/libraries/base/Control/Monad/Zip.hs
+++ b/libraries/base/Control/Monad/Zip.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE Safe #-}
+{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
@@ -19,6 +20,7 @@ module Control.Monad.Zip where
import Control.Monad (liftM, liftM2)
import Data.Monoid
+import GHC.Generics
-- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith`
--
@@ -75,3 +77,16 @@ instance MonadZip Last where
instance MonadZip f => MonadZip (Alt f) where
mzipWith f (Alt ma) (Alt mb) = Alt (mzipWith f ma mb)
+
+-- Instances for GHC.Generics
+instance MonadZip Par1 where
+ mzipWith = liftM2
+
+instance MonadZip f => MonadZip (Rec1 f) where
+ mzipWith f (Rec1 fa) (Rec1 fb) = Rec1 (mzipWith f fa fb)
+
+instance MonadZip f => MonadZip (M1 i c f) where
+ mzipWith f (M1 fa) (M1 fb) = M1 (mzipWith f fa fb)
+
+instance (MonadZip f, MonadZip g) => MonadZip (f :*: g) where
+ mzipWith f (x1 :*: y1) (x2 :*: y2) = mzipWith f x1 x2 :*: mzipWith f y1 y2
diff --git a/libraries/base/Data/Bifunctor.hs b/libraries/base/Data/Bifunctor.hs
index 2412ce7d30..9cc3c1c11b 100644
--- a/libraries/base/Data/Bifunctor.hs
+++ b/libraries/base/Data/Bifunctor.hs
@@ -18,6 +18,7 @@ module Data.Bifunctor
) where
import Control.Applicative ( Const(..) )
+import GHC.Generics ( K1(..) )
-- | Formally, the class 'Bifunctor' represents a bifunctor
-- from @Hask@ -> @Hask@.
@@ -99,3 +100,6 @@ instance Bifunctor Either where
instance Bifunctor Const where
bimap f _ (Const a) = Const (f a)
+
+instance Bifunctor (K1 i) where
+ bimap f _ (K1 c) = K1 (f c)
diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs
index cc94bac30f..fd189ed039 100644
--- a/libraries/base/Data/Data.hs
+++ b/libraries/base/Data/Data.hs
@@ -3,6 +3,7 @@
TypeOperators, GADTs, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -133,7 +134,9 @@ import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr
--import GHC.ST -- So we can give Data instance for ST
--import GHC.Conc -- So we can give Data instance for MVar & Co.
import GHC.Arr -- So we can give Data instance for Array
-
+import qualified GHC.Generics as Generics (Fixity(..))
+import GHC.Generics hiding (Fixity(..))
+ -- So we can give Data instance for U1, V1, ...
------------------------------------------------------------------------------
--
@@ -1509,3 +1512,307 @@ instance (Data (f a), Data a, Typeable f) => Data (Alt f a) where
gunfold k z _ = k (z Alt)
toConstr (Alt _) = altConstr
dataTypeOf _ = altDataType
+
+-----------------------------------------------------------------------
+-- instances for GHC.Generics
+
+u1Constr :: Constr
+u1Constr = mkConstr u1DataType "U1" [] Prefix
+
+u1DataType :: DataType
+u1DataType = mkDataType "GHC.Generics.U1" [u1Constr]
+
+instance Data p => Data (U1 p) where
+ gfoldl _ z U1 = z U1
+ toConstr U1 = u1Constr
+ gunfold _ z c = case constrIndex c of
+ 1 -> z U1
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(U1)"
+ dataTypeOf _ = u1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+par1Constr :: Constr
+par1Constr = mkConstr par1DataType "Par1" [] Prefix
+
+par1DataType :: DataType
+par1DataType = mkDataType "GHC.Generics.Par1" [par1Constr]
+
+instance Data p => Data (Par1 p) where
+ gfoldl k z (Par1 p) = z Par1 `k` p
+ toConstr (Par1 _) = par1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z Par1)
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(Par1)"
+ dataTypeOf _ = par1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+rec1Constr :: Constr
+rec1Constr = mkConstr rec1DataType "Rec1" [] Prefix
+
+rec1DataType :: DataType
+rec1DataType = mkDataType "GHC.Generics.Rec1" [rec1Constr]
+
+instance (Data (f p), Typeable f, Data p) => Data (Rec1 f p) where
+ gfoldl k z (Rec1 p) = z Rec1 `k` p
+ toConstr (Rec1 _) = rec1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z Rec1)
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(Rec1)"
+ dataTypeOf _ = rec1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+k1Constr :: Constr
+k1Constr = mkConstr k1DataType "K1" [] Prefix
+
+k1DataType :: DataType
+k1DataType = mkDataType "GHC.Generics.K1" [k1Constr]
+
+instance (Typeable i, Data p, Data c) => Data (K1 i c p) where
+ gfoldl k z (K1 p) = z K1 `k` p
+ toConstr (K1 _) = k1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z K1)
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(K1)"
+ dataTypeOf _ = k1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+m1Constr :: Constr
+m1Constr = mkConstr m1DataType "M1" [] Prefix
+
+m1DataType :: DataType
+m1DataType = mkDataType "GHC.Generics.M1" [m1Constr]
+
+instance (Data p, Data (f p), Typeable c, Typeable i, Typeable f)
+ => Data (M1 i c f p) where
+ gfoldl k z (M1 p) = z M1 `k` p
+ toConstr (M1 _) = m1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z M1)
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(M1)"
+ dataTypeOf _ = m1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+sum1DataType :: DataType
+sum1DataType = mkDataType "GHC.Generics.:+:" [l1Constr, r1Constr]
+
+l1Constr :: Constr
+l1Constr = mkConstr sum1DataType "L1" [] Prefix
+
+r1Constr :: Constr
+r1Constr = mkConstr sum1DataType "R1" [] Prefix
+
+instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p))
+ => Data ((f :+: g) p) where
+ gfoldl k z (L1 a) = z L1 `k` a
+ gfoldl k z (R1 a) = z R1 `k` a
+ toConstr L1{} = l1Constr
+ toConstr R1{} = r1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z L1)
+ 2 -> k (z R1)
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(:+:)"
+ dataTypeOf _ = sum1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+comp1Constr :: Constr
+comp1Constr = mkConstr comp1DataType "Comp1" [] Prefix
+
+comp1DataType :: DataType
+comp1DataType = mkDataType "GHC.Generics.:.:" [comp1Constr]
+
+instance (Typeable f, Typeable g, Data p, Data (f (g p)))
+ => Data ((f :.: g) p) where
+ gfoldl k z (Comp1 c) = z Comp1 `k` c
+ toConstr (Comp1 _) = m1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z Comp1)
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(:.:)"
+ dataTypeOf _ = comp1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+v1DataType :: DataType
+v1DataType = mkDataType "GHC.Generics.V1" []
+
+instance Data p => Data (V1 p) where
+ gfoldl _ _ !_ = undefined
+ toConstr !_ = undefined
+ gunfold _ _ _ = errorWithoutStackTrace "Data.Data.gunfold(V1)"
+ dataTypeOf _ = v1DataType
+ dataCast1 f = gcast1 f
+
+-----------------------------------------------------------------------
+
+prod1DataType :: DataType
+prod1DataType = mkDataType "GHC.Generics.:*:" [prod1Constr]
+
+prod1Constr :: Constr
+prod1Constr = mkConstr prod1DataType "Prod1" [] Infix
+
+instance (Typeable f, Typeable g, Data p, Data (f p), Data (g p))
+ => Data ((f :*: g) p) where
+ gfoldl k z (l :*: r) = z (:*:) `k` l `k` r
+ toConstr _ = prod1Constr
+ gunfold k z c = case constrIndex c of
+ 1 -> k (k (z (:*:)))
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(:*:)"
+ dataCast1 f = gcast1 f
+ dataTypeOf _ = prod1DataType
+
+-----------------------------------------------------------------------
+
+prefixConstr :: Constr
+prefixConstr = mkConstr fixityDataType "Prefix" [] Prefix
+infixConstr :: Constr
+infixConstr = mkConstr fixityDataType "Infix" [] Prefix
+
+fixityDataType :: DataType
+fixityDataType = mkDataType "GHC.Generics.Fixity" [prefixConstr,infixConstr]
+
+instance Data Generics.Fixity where
+ gfoldl _ z Generics.Prefix = z Generics.Prefix
+ gfoldl f z (Generics.Infix a i) = z Generics.Infix `f` a `f` i
+ toConstr Generics.Prefix = prefixConstr
+ toConstr Generics.Infix{} = infixConstr
+ gunfold k z c = case constrIndex c of
+ 1 -> z Generics.Prefix
+ 2 -> k (k (z Generics.Infix))
+ _ -> errorWithoutStackTrace "Data.Data.gunfold(Fixity)"
+ dataTypeOf _ = fixityDataType
+
+-----------------------------------------------------------------------
+
+leftAssociativeConstr :: Constr
+leftAssociativeConstr
+ = mkConstr associativityDataType "LeftAssociative" [] Prefix
+rightAssociativeConstr :: Constr
+rightAssociativeConstr
+ = mkConstr associativityDataType "RightAssociative" [] Prefix
+notAssociativeConstr :: Constr
+notAssociativeConstr
+ = mkConstr associativityDataType "NotAssociative" [] Prefix
+
+associativityDataType :: DataType
+associativityDataType = mkDataType "GHC.Generics.Associativity"
+ [leftAssociativeConstr,rightAssociativeConstr,notAssociativeConstr]
+
+instance Data Associativity where
+ gfoldl _ z LeftAssociative = z LeftAssociative
+ gfoldl _ z RightAssociative = z RightAssociative
+ gfoldl _ z NotAssociative = z NotAssociative
+ toConstr LeftAssociative = leftAssociativeConstr
+ toConstr RightAssociative = rightAssociativeConstr
+ toConstr NotAssociative = notAssociativeConstr
+ gunfold _ z c = case constrIndex c of
+ 1 -> z LeftAssociative
+ 2 -> z RightAssociative
+ 3 -> z NotAssociative
+ _ -> errorWithoutStackTrace
+ "Data.Data.gunfold(Associativity)"
+ dataTypeOf _ = associativityDataType
+
+-----------------------------------------------------------------------
+
+noSourceUnpackednessConstr :: Constr
+noSourceUnpackednessConstr
+ = mkConstr sourceUnpackednessDataType "NoSourceUnpackedness" [] Prefix
+sourceNoUnpackConstr :: Constr
+sourceNoUnpackConstr
+ = mkConstr sourceUnpackednessDataType "SourceNoUnpack" [] Prefix
+sourceUnpackConstr :: Constr
+sourceUnpackConstr
+ = mkConstr sourceUnpackednessDataType "SourceUnpack" [] Prefix
+
+sourceUnpackednessDataType :: DataType
+sourceUnpackednessDataType = mkDataType "GHC.Generics.SourceUnpackedness"
+ [noSourceUnpackednessConstr,sourceNoUnpackConstr,sourceUnpackConstr]
+
+instance Data SourceUnpackedness where
+ gfoldl _ z NoSourceUnpackedness = z NoSourceUnpackedness
+ gfoldl _ z SourceNoUnpack = z SourceNoUnpack
+ gfoldl _ z SourceUnpack = z SourceUnpack
+ toConstr NoSourceUnpackedness = noSourceUnpackednessConstr
+ toConstr SourceNoUnpack = sourceNoUnpackConstr
+ toConstr SourceUnpack = sourceUnpackConstr
+ gunfold _ z c = case constrIndex c of
+ 1 -> z NoSourceUnpackedness
+ 2 -> z SourceNoUnpack
+ 3 -> z SourceUnpack
+ _ -> errorWithoutStackTrace
+ "Data.Data.gunfold(SourceUnpackedness)"
+ dataTypeOf _ = sourceUnpackednessDataType
+
+-----------------------------------------------------------------------
+
+noSourceStrictnessConstr :: Constr
+noSourceStrictnessConstr
+ = mkConstr sourceStrictnessDataType "NoSourceStrictness" [] Prefix
+sourceLazyConstr :: Constr
+sourceLazyConstr
+ = mkConstr sourceStrictnessDataType "SourceLazy" [] Prefix
+sourceStrictConstr :: Constr
+sourceStrictConstr
+ = mkConstr sourceStrictnessDataType "SourceStrict" [] Prefix
+
+sourceStrictnessDataType :: DataType
+sourceStrictnessDataType = mkDataType "GHC.Generics.SourceStrictness"
+ [noSourceStrictnessConstr,sourceLazyConstr,sourceStrictConstr]
+
+instance Data SourceStrictness where
+ gfoldl _ z NoSourceStrictness = z NoSourceStrictness
+ gfoldl _ z SourceLazy = z SourceLazy
+ gfoldl _ z SourceStrict = z SourceStrict
+ toConstr NoSourceStrictness = noSourceStrictnessConstr
+ toConstr SourceLazy = sourceLazyConstr
+ toConstr SourceStrict = sourceStrictConstr
+ gunfold _ z c = case constrIndex c of
+ 1 -> z NoSourceStrictness
+ 2 -> z SourceLazy
+ 3 -> z SourceStrict
+ _ -> errorWithoutStackTrace
+ "Data.Data.gunfold(SourceStrictness)"
+ dataTypeOf _ = sourceStrictnessDataType
+
+-----------------------------------------------------------------------
+
+decidedLazyConstr :: Constr
+decidedLazyConstr
+ = mkConstr decidedStrictnessDataType "DecidedLazy" [] Prefix
+decidedStrictConstr :: Constr
+decidedStrictConstr
+ = mkConstr decidedStrictnessDataType "DecidedStrict" [] Prefix
+decidedUnpackConstr :: Constr
+decidedUnpackConstr
+ = mkConstr decidedStrictnessDataType "DecidedUnpack" [] Prefix
+
+decidedStrictnessDataType :: DataType
+decidedStrictnessDataType = mkDataType "GHC.Generics.DecidedStrictness"
+ [decidedLazyConstr,decidedStrictConstr,decidedUnpackConstr]
+
+instance Data DecidedStrictness where
+ gfoldl _ z DecidedLazy = z DecidedLazy
+ gfoldl _ z DecidedStrict = z DecidedStrict
+ gfoldl _ z DecidedUnpack = z DecidedUnpack
+ toConstr DecidedLazy = decidedLazyConstr
+ toConstr DecidedStrict = decidedStrictConstr
+ toConstr DecidedUnpack = decidedUnpackConstr
+ gunfold _ z c = case constrIndex c of
+ 1 -> z DecidedLazy
+ 2 -> z DecidedStrict
+ 3 -> z DecidedUnpack
+ _ -> errorWithoutStackTrace
+ "Data.Data.gunfold(DecidedStrictness)"
+ dataTypeOf _ = decidedStrictnessDataType
diff --git a/libraries/base/Data/Foldable.hs b/libraries/base/Data/Foldable.hs
index 3d518d5c4b..5d758ae691 100644
--- a/libraries/base/Data/Foldable.hs
+++ b/libraries/base/Data/Foldable.hs
@@ -1,6 +1,10 @@
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
@@ -61,6 +65,7 @@ import GHC.Arr ( Array(..), elems, numElements,
foldlElems', foldrElems',
foldl1Elems, foldr1Elems)
import GHC.Base hiding ( foldr )
+import GHC.Generics
import GHC.Num ( Num(..) )
infix 4 `elem`, `notElem`
@@ -419,6 +424,23 @@ instance Ord a => Monoid (Min a) where
| x <= y = Min m
| otherwise = Min n
+-- Instances for GHC.Generics
+deriving instance Foldable V1
+deriving instance Foldable U1
+deriving instance Foldable Par1
+deriving instance Foldable f => Foldable (Rec1 f)
+deriving instance Foldable (K1 i c)
+deriving instance Foldable f => Foldable (M1 i c f)
+deriving instance (Foldable f, Foldable g) => Foldable (f :+: g)
+deriving instance (Foldable f, Foldable g) => Foldable (f :*: g)
+deriving instance (Foldable f, Foldable g) => Foldable (f :.: g)
+deriving instance Foldable UAddr
+deriving instance Foldable UChar
+deriving instance Foldable UDouble
+deriving instance Foldable UFloat
+deriving instance Foldable UInt
+deriving instance Foldable UWord
+
-- | Monadic fold over the elements of a structure,
-- associating to the right, i.e. from right to left.
foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b
diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs
index 9da76c6a34..c6a30d7213 100644
--- a/libraries/base/Data/Traversable.hs
+++ b/libraries/base/Data/Traversable.hs
@@ -1,5 +1,9 @@
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
@@ -58,6 +62,7 @@ import Data.Proxy ( Proxy(..) )
import GHC.Arr
import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..),
($), (.), id, flip )
+import GHC.Generics
import qualified GHC.List as List ( foldr )
-- | Functors representing data structures that can be traversed from
@@ -222,6 +227,23 @@ instance Traversable Last where
instance Traversable ZipList where
traverse f (ZipList x) = ZipList <$> traverse f x
+-- Instances for GHC.Generics
+deriving instance Traversable V1
+deriving instance Traversable U1
+deriving instance Traversable Par1
+deriving instance Traversable f => Traversable (Rec1 f)
+deriving instance Traversable (K1 i c)
+deriving instance Traversable f => Traversable (M1 i c f)
+deriving instance (Traversable f, Traversable g) => Traversable (f :+: g)
+deriving instance (Traversable f, Traversable g) => Traversable (f :*: g)
+deriving instance (Traversable f, Traversable g) => Traversable (f :.: g)
+deriving instance Traversable UAddr
+deriving instance Traversable UChar
+deriving instance Traversable UDouble
+deriving instance Traversable UFloat
+deriving instance Traversable UInt
+deriving instance Traversable UWord
+
-- general functions
-- | 'for' is 'traverse' with its arguments flipped. For a version
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index 27f2c573ca..4e01c137f3 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -700,16 +701,19 @@ module GHC.Generics (
) where
-- We use some base types
+import Data.Either ( Either (..) )
+import Data.Maybe ( Maybe(..), fromMaybe )
import GHC.Integer ( Integer, integerToInt )
-import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
-import GHC.Ptr ( Ptr )
+import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )
+import GHC.Ptr ( Ptr )
import GHC.Types
-import Data.Maybe ( Maybe(..), fromMaybe )
-import Data.Either ( Either(..) )
-- Needed for instances
-import GHC.Base ( String )
+import GHC.Arr ( Ix )
+import GHC.Base ( Alternative(..), Applicative(..), Functor(..)
+ , Monad(..), MonadPlus(..), String )
import GHC.Classes ( Eq, Ord )
+import GHC.Enum ( Bounded, Enum )
import GHC.Read ( Read )
import GHC.Show ( Show )
@@ -723,41 +727,115 @@ import GHC.TypeLits ( Nat, Symbol, KnownSymbol, KnownNat, symbolVal, natVal )
-- | Void: used for datatypes without constructors
data V1 (p :: *)
+ deriving (Functor, Generic, Generic1)
+
+deriving instance Eq (V1 p)
+deriving instance Ord (V1 p)
+deriving instance Read (V1 p)
+deriving instance Show (V1 p)
-- | Unit: used for constructors without arguments
data U1 (p :: *) = U1
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
+
+instance Applicative U1 where
+ pure _ = U1
+ U1 <*> U1 = U1
+
+instance Alternative U1 where
+ empty = U1
+ U1 <|> U1 = U1
+
+instance Monad U1 where
+ U1 >>= _ = U1
-- | Used for marking occurrences of the parameter
newtype Par1 p = Par1 { unPar1 :: p }
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
+
+instance Applicative Par1 where
+ pure a = Par1 a
+ Par1 f <*> Par1 x = Par1 (f x)
+
+instance Monad Par1 where
+ Par1 x >>= f = f x
-- | Recursive calls of kind * -> *
newtype Rec1 f (p :: *) = Rec1 { unRec1 :: f p }
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
+
+instance Applicative f => Applicative (Rec1 f) where
+ pure a = Rec1 (pure a)
+ Rec1 f <*> Rec1 x = Rec1 (f <*> x)
+
+instance Alternative f => Alternative (Rec1 f) where
+ empty = Rec1 empty
+ Rec1 l <|> Rec1 r = Rec1 (l <|> r)
+
+instance Monad f => Monad (Rec1 f) where
+ Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a))
+
+instance MonadPlus f => MonadPlus (Rec1 f)
-- | Constants, additional parameters and recursion of kind *
newtype K1 (i :: *) c (p :: *) = K1 { unK1 :: c }
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
+
+instance Applicative f => Applicative (M1 i c f) where
+ pure a = M1 (pure a)
+ M1 f <*> M1 x = M1 (f <*> x)
+
+instance Alternative f => Alternative (M1 i c f) where
+ empty = M1 empty
+ M1 l <|> M1 r = M1 (l <|> r)
+
+instance Monad f => Monad (M1 i c f) where
+ M1 x >>= f = M1 (x >>= \a -> unM1 (f a))
+
+instance MonadPlus f => MonadPlus (M1 i c f)
-- | Meta-information (constructor names, etc.)
newtype M1 (i :: *) (c :: Meta) f (p :: *) = M1 { unM1 :: f p }
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
-- | Sums: encode choice between constructors
infixr 5 :+:
data (:+:) f g (p :: *) = L1 (f p) | R1 (g p)
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
-- | Products: encode multiple arguments to constructors
infixr 6 :*:
data (:*:) f g (p :: *) = f p :*: g p
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
+
+instance (Applicative f, Applicative g) => Applicative (f :*: g) where
+ pure a = pure a :*: pure a
+ (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y)
+
+instance (Alternative f, Alternative g) => Alternative (f :*: g) where
+ empty = empty :*: empty
+ (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2)
+
+instance (Monad f, Monad g) => Monad (f :*: g) where
+ (m :*: n) >>= f = (m >>= \a -> fstP (f a)) :*: (n >>= \a -> sndP (f a))
+ where
+ fstP (a :*: _) = a
+ sndP (_ :*: b) = b
+
+instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g)
-- | Composition of functors
infixr 7 :.:
newtype (:.:) f (g :: * -> *) (p :: *) = Comp1 { unComp1 :: f (g p) }
- deriving (Eq, Ord, Read, Show, Generic)
+ deriving (Eq, Ord, Read, Show, Functor, Generic, Generic1)
+
+instance (Applicative f, Applicative g) => Applicative (f :.: g) where
+ pure x = Comp1 (pure (pure x))
+ Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x)
+
+instance (Alternative f, Applicative g) => Alternative (f :.: g) where
+ empty = Comp1 empty
+ Comp1 x <|> Comp1 y = Comp1 (x <|> y)
-- | Constants of kind @#@
--
@@ -768,37 +846,37 @@ data family URec (a :: *) (p :: *)
--
-- @since 4.9.0.0
data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# }
- deriving (Eq, Ord, Generic)
+ deriving (Eq, Ord, Functor, Generic, Generic1)
-- | Used for marking occurrences of 'Char#'
--
-- @since 4.9.0.0
data instance URec Char p = UChar { uChar# :: Char# }
- deriving (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Functor, Generic, Generic1)
-- | Used for marking occurrences of 'Double#'
--
-- @since 4.9.0.0
data instance URec Double p = UDouble { uDouble# :: Double# }
- deriving (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Functor, Generic, Generic1)
-- | Used for marking occurrences of 'Float#'
--
-- @since 4.9.0.0
data instance URec Float p = UFloat { uFloat# :: Float# }
- deriving (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Functor, Generic, Generic1)
-- | Used for marking occurrences of 'Int#'
--
-- @since 4.9.0.0
data instance URec Int p = UInt { uInt# :: Int# }
- deriving (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Functor, Generic, Generic1)
-- | Used for marking occurrences of 'Word#'
--
-- @since 4.9.0.0
data instance URec Word p = UWord { uWord# :: Word# }
- deriving (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Functor, Generic, Generic1)
-- | Type synonym for 'URec': 'Addr#'
--
@@ -908,7 +986,7 @@ prec (Infix _ n) = n
data Associativity = LeftAssociative
| RightAssociative
| NotAssociative
- deriving (Eq, Show, Ord, Read, Generic)
+ deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic)
-- | The unpackedness of a field as the user wrote it in the source code. For
-- example, in the following data type:
@@ -926,7 +1004,7 @@ data Associativity = LeftAssociative
data SourceUnpackedness = NoSourceUnpackedness
| SourceNoUnpack
| SourceUnpack
- deriving (Eq, Show, Ord, Read, Generic)
+ deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic)
-- | The strictness of a field as the user wrote it in the source code. For
-- example, in the following data type:
@@ -942,7 +1020,7 @@ data SourceUnpackedness = NoSourceUnpackedness
data SourceStrictness = NoSourceStrictness
| SourceLazy
| SourceStrict
- deriving (Eq, Show, Ord, Read, Generic)
+ deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic)
-- | The strictness that GHC infers for a field during compilation. Whereas
-- there are nine different combinations of 'SourceUnpackedness' and
@@ -969,7 +1047,7 @@ data SourceStrictness = NoSourceStrictness
data DecidedStrictness = DecidedLazy
| DecidedStrict
| DecidedUnpack
- deriving (Eq, Show, Ord, Read, Generic)
+ deriving (Eq, Show, Ord, Read, Enum, Bounded, Ix, Generic)
-- | Class for datatypes that represent records
class Selector s where
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 7f2f2d3e42..b0ccda6e11 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -104,6 +104,11 @@
* `Alt`, `Dual`, `First`, `Last`, `Product`, and `Sum` now have `Data`,
`MonadZip`, and `MonadFix` instances
+ * The datatypes in `GHC.Generics` now have `Enum`, `Bounded`, `Ix`,
+ `Functor`, `Applicative`, `Monad`, `MonadFix`, `MonadPlus`, `MonadZip`,
+ `Foldable`, `Foldable`, `Traversable`, `Generic1`, and `Data` instances
+ as appropriate.
+
* `Maybe` now has a `MonadZip` instance
* `All` and `Any` now have `Data` instances