1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE EmptyDataDecls #-}
4{-# LANGUAGE TypeFamilies #-}
5
6#if __GLASGOW_HASKELL__ >= 702
7{-# LANGUAGE DeriveGeneric #-}
8#endif
9
10#if __GLASGOW_HASKELL__ >= 706
11{-# LANGUAGE PolyKinds #-}
12#endif
13
14#if __GLASGOW_HASKELL__ >= 708
15{-# LANGUAGE Safe #-}
16#elif __GLASGOW_HASKELL__ >= 702
17{-# LANGUAGE Trustworthy #-}
18#endif
19#include "bifunctors-common.h"
20
21-----------------------------------------------------------------------------
22-- |
23-- Copyright   :  (C) 2008-2016 Jesse Selover, Edward Kmett
24-- License     :  BSD-style (see the file LICENSE)
25--
26-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
27-- Stability   :  provisional
28-- Portability :  portable
29--
30-- The product of two bifunctors.
31----------------------------------------------------------------------------
32module Data.Bifunctor.Product
33  ( Product(..)
34  ) where
35
36#if __GLASGOW_HASKELL__ < 710
37import Control.Applicative
38#endif
39
40import qualified Control.Arrow as A
41import Control.Category
42import Data.Biapplicative
43import Data.Bifoldable
44import Data.Bifunctor.Functor
45import Data.Bitraversable
46
47#if __GLASGOW_HASKELL__ < 710
48import Data.Monoid hiding (Product)
49#endif
50
51#if __GLASGOW_HASKELL__ >= 708
52import Data.Typeable
53#endif
54
55#if __GLASGOW_HASKELL__ >= 702
56import GHC.Generics
57#endif
58
59#if LIFTED_FUNCTOR_CLASSES
60import Data.Functor.Classes
61#endif
62
63import Prelude hiding ((.),id)
64
65-- | Form the product of two bifunctors
66data Product f g a b = Pair (f a b) (g a b)
67  deriving ( Eq, Ord, Show, Read
68#if __GLASGOW_HASKELL__ >= 702
69           , Generic
70#endif
71#if __GLASGOW_HASKELL__ >= 708
72           , Generic1
73           , Typeable
74#endif
75           )
76
77#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708
78data ProductMetaData
79data ProductMetaCons
80
81instance Datatype ProductMetaData where
82    datatypeName _ = "Product"
83    moduleName _ = "Data.Bifunctor.Product"
84
85instance Constructor ProductMetaCons where
86    conName _ = "Pair"
87
88instance Generic1 (Product f g a) where
89    type Rep1 (Product f g a) = D1 ProductMetaData (C1 ProductMetaCons ((:*:)
90        (S1 NoSelector (Rec1 (f a)))
91        (S1 NoSelector (Rec1 (g a)))))
92    from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))
93    to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)
94#endif
95
96#if LIFTED_FUNCTOR_CLASSES
97instance (Eq2 f, Eq2 g, Eq a) => Eq1 (Product f g a) where
98  liftEq = liftEq2 (==)
99instance (Eq2 f, Eq2 g) => Eq2 (Product f g) where
100  liftEq2 f g (Pair x1 y1) (Pair x2 y2) =
101    liftEq2 f g x1 x2 && liftEq2 f g y1 y2
102
103instance (Ord2 f, Ord2 g, Ord a) => Ord1 (Product f g a) where
104  liftCompare = liftCompare2 compare
105instance (Ord2 f, Ord2 g) => Ord2 (Product f g) where
106  liftCompare2 f g (Pair x1 y1) (Pair x2 y2) =
107    liftCompare2 f g x1 x2 `mappend` liftCompare2 f g y1 y2
108
109instance (Read2 f, Read2 g, Read a) => Read1 (Product f g a) where
110  liftReadsPrec = liftReadsPrec2 readsPrec readList
111instance (Read2 f, Read2 g) => Read2 (Product f g) where
112  liftReadsPrec2 rp1 rl1 rp2 rl2 = readsData $
113    readsBinaryWith (liftReadsPrec2 rp1 rl1 rp2 rl2)
114                    (liftReadsPrec2 rp1 rl1 rp2 rl2)
115                    "Pair" Pair
116
117instance (Show2 f, Show2 g, Show a) => Show1 (Product f g a) where
118  liftShowsPrec = liftShowsPrec2 showsPrec showList
119instance (Show2 f, Show2 g) => Show2 (Product f g) where
120  liftShowsPrec2 sp1 sl1 sp2 sl2 p (Pair x y) =
121    showsBinaryWith (liftShowsPrec2 sp1 sl1 sp2 sl2)
122                    (liftShowsPrec2 sp1 sl1 sp2 sl2)
123                    "Pair" p x y
124#endif
125
126instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where
127  first f (Pair x y) = Pair (first f x) (first f y)
128  {-# INLINE first #-}
129  second g (Pair x y) = Pair (second g x) (second g y)
130  {-# INLINE second #-}
131  bimap f g (Pair x y) = Pair (bimap f g x) (bimap f g y)
132  {-# INLINE bimap #-}
133
134instance (Biapplicative f, Biapplicative g) => Biapplicative (Product f g) where
135  bipure a b = Pair (bipure a b) (bipure a b)
136  {-# INLINE bipure #-}
137  Pair w x <<*>> Pair y z = Pair (w <<*>> y) (x <<*>> z)
138  {-# INLINE (<<*>>) #-}
139
140instance (Bifoldable f, Bifoldable g) => Bifoldable (Product f g) where
141  bifoldMap f g (Pair x y) = bifoldMap f g x `mappend` bifoldMap f g y
142  {-# INLINE bifoldMap #-}
143
144instance (Bitraversable f, Bitraversable g) => Bitraversable (Product f g) where
145  bitraverse f g (Pair x y) = Pair <$> bitraverse f g x <*> bitraverse f g y
146  {-# INLINE bitraverse #-}
147
148instance BifunctorFunctor (Product p) where
149  bifmap f (Pair p q) = Pair p (f q)
150
151instance BifunctorComonad (Product p) where
152  biextract (Pair _ q) = q
153  biduplicate pq@(Pair p _) = Pair p pq
154  biextend f pq@(Pair p _) = Pair p (f pq)
155
156instance (Category p, Category q) => Category (Product p q) where
157  id = Pair id id
158  Pair x y . Pair x' y' = Pair (x . x') (y . y')
159
160instance (A.Arrow p, A.Arrow q) => A.Arrow (Product p q) where
161  arr f = Pair (A.arr f) (A.arr f)
162  first (Pair x y) = Pair (A.first x) (A.first y)
163  second (Pair x y) = Pair (A.second x) (A.second y)
164  Pair x y *** Pair x' y' = Pair (x A.*** x') (y A.*** y')
165  Pair x y &&& Pair x' y' = Pair (x A.&&& x') (y A.&&& y')
166
167instance (A.ArrowChoice p, A.ArrowChoice q) => A.ArrowChoice (Product p q) where
168  left (Pair x y) = Pair (A.left x) (A.left y)
169  right (Pair x y) = Pair (A.right x) (A.right y)
170  Pair x y +++ Pair x' y' = Pair (x A.+++ x') (y A.+++ y')
171  Pair x y ||| Pair x' y' = Pair (x A.||| x') (y A.||| y')
172
173instance (A.ArrowLoop p, A.ArrowLoop q) => A.ArrowLoop (Product p q) where
174  loop (Pair x y) = Pair (A.loop x) (A.loop y)
175
176instance (A.ArrowZero p, A.ArrowZero q) => A.ArrowZero (Product p q) where
177  zeroArrow = Pair A.zeroArrow A.zeroArrow
178
179instance (A.ArrowPlus p, A.ArrowPlus q) => A.ArrowPlus (Product p q) where
180  Pair x y <+> Pair x' y' = Pair (x A.<+> x') (y A.<+> y')
181