diff options
author | RyanGlScott <ryan.gl.scott@gmail.com> | 2016-02-25 14:49:48 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2016-02-25 15:41:55 +0100 |
commit | 673efccb3b348e9daf23d9e65460691bbea8586e (patch) | |
tree | 825b41d829a0e032a2db18386edd5a39036c2dc2 /libraries | |
parent | 6319a8cf79cc1f1e25220113149ab48e5083321b (diff) | |
download | haskell-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.hs | 18 | ||||
-rw-r--r-- | libraries/base/Control/Monad/Zip.hs | 15 | ||||
-rw-r--r-- | libraries/base/Data/Bifunctor.hs | 4 | ||||
-rw-r--r-- | libraries/base/Data/Data.hs | 309 | ||||
-rw-r--r-- | libraries/base/Data/Foldable.hs | 24 | ||||
-rw-r--r-- | libraries/base/Data/Traversable.hs | 24 | ||||
-rw-r--r-- | libraries/base/GHC/Generics.hs | 124 | ||||
-rw-r--r-- | libraries/base/changelog.md | 5 |
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 |