1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE EmptyDataDecls #-} 4{-# LANGUAGE FlexibleContexts #-} 5{-# LANGUAGE StandaloneDeriving #-} 6{-# LANGUAGE TypeFamilies #-} 7{-# LANGUAGE TypeOperators #-} 8 9#if __GLASGOW_HASKELL__ >= 702 10{-# LANGUAGE DeriveGeneric #-} 11#endif 12 13#if __GLASGOW_HASKELL__ >= 706 14{-# LANGUAGE PolyKinds #-} 15#endif 16 17#if __GLASGOW_HASKELL__ >= 708 18{-# LANGUAGE Safe #-} 19#elif __GLASGOW_HASKELL__ >= 702 20{-# LANGUAGE Trustworthy #-} 21#endif 22#include "bifunctors-common.h" 23 24----------------------------------------------------------------------------- 25-- | 26-- Copyright : (C) 2008-2016 Edward Kmett 27-- License : BSD-style (see the file LICENSE) 28-- 29-- Maintainer : Edward Kmett <ekmett@gmail.com> 30-- Stability : provisional 31-- Portability : portable 32-- 33---------------------------------------------------------------------------- 34module Data.Bifunctor.Biff 35 ( Biff(..) 36 ) where 37 38#if __GLASGOW_HASKELL__ < 710 39import Control.Applicative 40#endif 41 42import Data.Biapplicative 43import Data.Bifoldable 44import Data.Bitraversable 45 46#if __GLASGOW_HASKELL__ < 710 47import Data.Foldable 48import Data.Monoid 49import Data.Traversable 50#endif 51 52#if __GLASGOW_HASKELL__ >= 708 53import Data.Typeable 54#endif 55 56#if __GLASGOW_HASKELL__ >= 702 57import GHC.Generics 58#endif 59 60#if LIFTED_FUNCTOR_CLASSES 61import Data.Functor.Classes 62#endif 63 64-- | Compose two 'Functor's on the inside of a 'Bifunctor'. 65newtype Biff p f g a b = Biff { runBiff :: p (f a) (g b) } 66 deriving ( Eq, Ord, Show, Read 67#if __GLASGOW_HASKELL__ >= 702 68 , Generic 69#endif 70#if __GLASGOW_HASKELL__ >= 708 71 , Typeable 72#endif 73 ) 74#if __GLASGOW_HASKELL__ >= 702 75# if __GLASGOW_HASKELL__ >= 708 76deriving instance Functor (p (f a)) => Generic1 (Biff p f g a) 77# else 78data BiffMetaData 79data BiffMetaCons 80data BiffMetaSel 81 82instance Datatype BiffMetaData where 83 datatypeName = const "Biff" 84 moduleName = const "Data.Bifunctor.Biff" 85 86instance Constructor BiffMetaCons where 87 conName = const "Biff" 88 conIsRecord = const True 89 90instance Selector BiffMetaSel where 91 selName = const "runBiff" 92 93instance Functor (p (f a)) => Generic1 (Biff p f g a) where 94 type Rep1 (Biff p f g a) = D1 BiffMetaData (C1 BiffMetaCons 95 (S1 BiffMetaSel (p (f a) :.: Rec1 g))) 96 from1 = M1 . M1 . M1 . Comp1 . fmap Rec1 . runBiff 97 to1 = Biff . fmap unRec1 . unComp1 . unM1 . unM1 . unM1 98# endif 99#endif 100 101#if LIFTED_FUNCTOR_CLASSES 102instance (Eq2 p, Eq1 f, Eq1 g, Eq a) => Eq1 (Biff p f g a) where 103 liftEq = liftEq2 (==) 104instance (Eq2 p, Eq1 f, Eq1 g) => Eq2 (Biff p f g) where 105 liftEq2 f g (Biff x) (Biff y) = liftEq2 (liftEq f) (liftEq g) x y 106 107instance (Ord2 p, Ord1 f, Ord1 g, Ord a) => Ord1 (Biff p f g a) where 108 liftCompare = liftCompare2 compare 109instance (Ord2 p, Ord1 f, Ord1 g) => Ord2 (Biff p f g) where 110 liftCompare2 f g (Biff x) (Biff y) = liftCompare2 (liftCompare f) (liftCompare g) x y 111 112instance (Read2 p, Read1 f, Read1 g, Read a) => Read1 (Biff p f g a) where 113 liftReadsPrec = liftReadsPrec2 readsPrec readList 114instance (Read2 p, Read1 f, Read1 g) => Read2 (Biff p f g) where 115 liftReadsPrec2 rp1 rl1 rp2 rl2 p = readParen (p > 10) $ \s0 -> do 116 ("Biff", s1) <- lex s0 117 ("{", s2) <- lex s1 118 ("runBiff", s3) <- lex s2 119 (x, s4) <- liftReadsPrec2 (liftReadsPrec rp1 rl1) (liftReadList rp1 rl1) 120 (liftReadsPrec rp2 rl2) (liftReadList rp2 rl2) 0 s3 121 ("}", s5) <- lex s4 122 return (Biff x, s5) 123 124instance (Show2 p, Show1 f, Show1 g, Show a) => Show1 (Biff p f g a) where 125 liftShowsPrec = liftShowsPrec2 showsPrec showList 126instance (Show2 p, Show1 f, Show1 g) => Show2 (Biff p f g) where 127 liftShowsPrec2 sp1 sl1 sp2 sl2 p (Biff x) = showParen (p > 10) $ 128 showString "Biff {runBiff = " 129 . liftShowsPrec2 (liftShowsPrec sp1 sl1) (liftShowList sp1 sl1) 130 (liftShowsPrec sp2 sl2) (liftShowList sp2 sl2) 0 x 131 . showChar '}' 132#endif 133 134instance (Bifunctor p, Functor f, Functor g) => Bifunctor (Biff p f g) where 135 first f = Biff . first (fmap f) . runBiff 136 {-# INLINE first #-} 137 second f = Biff . second (fmap f) . runBiff 138 {-# INLINE second #-} 139 bimap f g = Biff . bimap (fmap f) (fmap g) . runBiff 140 {-# INLINE bimap #-} 141 142instance (Bifunctor p, Functor g) => Functor (Biff p f g a) where 143 fmap f = Biff . second (fmap f) . runBiff 144 {-# INLINE fmap #-} 145 146instance (Biapplicative p, Applicative f, Applicative g) => Biapplicative (Biff p f g) where 147 bipure a b = Biff (bipure (pure a) (pure b)) 148 {-# INLINE bipure #-} 149 150 Biff fg <<*>> Biff xy = Biff (bimap (<*>) (<*>) fg <<*>> xy) 151 {-# INLINE (<<*>>) #-} 152 153instance (Bifoldable p, Foldable g) => Foldable (Biff p f g a) where 154 foldMap f = bifoldMap (const mempty) (foldMap f) . runBiff 155 {-# INLINE foldMap #-} 156 157instance (Bifoldable p, Foldable f, Foldable g) => Bifoldable (Biff p f g) where 158 bifoldMap f g = bifoldMap (foldMap f) (foldMap g) . runBiff 159 {-# INLINE bifoldMap #-} 160 161instance (Bitraversable p, Traversable g) => Traversable (Biff p f g a) where 162 traverse f = fmap Biff . bitraverse pure (traverse f) . runBiff 163 {-# INLINE traverse #-} 164 165instance (Bitraversable p, Traversable f, Traversable g) => Bitraversable (Biff p f g) where 166 bitraverse f g = fmap Biff . bitraverse (traverse f) (traverse g) . runBiff 167 {-# INLINE bitraverse #-} 168