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