Commit 673efccb authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent 6319a8cf
{-# 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
{-# 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
......@@ -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)
......@@ -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
{-# 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
......
{-# 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
......
{-# 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)