1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE StandaloneDeriving #-} 5{-# LANGUAGE UndecidableInstances #-} 6 7#if __GLASGOW_HASKELL__ >= 702 8{-# LANGUAGE DeriveGeneric #-} 9#endif 10 11#if __GLASGOW_HASKELL__ >= 704 12{-# LANGUAGE Safe #-} 13#elif __GLASGOW_HASKELL__ >= 702 14{-# LANGUAGE Trustworthy #-} 15#endif 16 17#if __GLASGOW_HASKELL__ >= 706 18{-# LANGUAGE PolyKinds #-} 19#endif 20#include "bifunctors-common.h" 21 22----------------------------------------------------------------------------- 23-- | 24-- Copyright : (C) 2008-2016 Edward Kmett 25-- License : BSD-style (see the file LICENSE) 26-- 27-- Maintainer : Edward Kmett <ekmett@gmail.com> 28-- Stability : provisional 29-- Portability : non-portable 30-- 31---------------------------------------------------------------------------- 32module Data.Bifunctor.Join 33 ( Join(..) 34 ) where 35 36#if __GLASGOW_HASKELL__ < 710 37import Control.Applicative 38#endif 39 40import Data.Biapplicative 41import Data.Bifoldable 42import Data.Bitraversable 43 44#if __GLASGOW_HASKELL__ < 710 45import Data.Foldable 46import Data.Traversable 47#endif 48 49#if __GLASGOW_HASKELL__ >= 708 50import Data.Typeable 51#endif 52 53#if __GLASGOW_HASKELL__ >= 702 54import GHC.Generics 55#endif 56 57#if LIFTED_FUNCTOR_CLASSES 58import Data.Functor.Classes 59#endif 60 61-- | Make a 'Functor' over both arguments of a 'Bifunctor'. 62newtype Join p a = Join { runJoin :: p a a } 63 deriving 64 ( 65#if __GLASGOW_HASKELL__ >= 702 66 Generic 67#endif 68#if __GLASGOW_HASKELL__ >= 708 69 , Typeable 70#endif 71 ) 72 73deriving instance Eq (p a a) => Eq (Join p a) 74deriving instance Ord (p a a) => Ord (Join p a) 75deriving instance Show (p a a) => Show (Join p a) 76deriving instance Read (p a a) => Read (Join p a) 77 78#if LIFTED_FUNCTOR_CLASSES 79instance Eq2 p => Eq1 (Join p) where 80 liftEq f (Join x) (Join y) = liftEq2 f f x y 81 82instance Ord2 p => Ord1 (Join p) where 83 liftCompare f (Join x) (Join y) = liftCompare2 f f x y 84 85instance Read2 p => Read1 (Join p) where 86 liftReadsPrec rp1 rl1 p = readParen (p > 10) $ \s0 -> do 87 ("Join", s1) <- lex s0 88 ("{", s2) <- lex s1 89 ("runJoin", s3) <- lex s2 90 (x, s4) <- liftReadsPrec2 rp1 rl1 rp1 rl1 0 s3 91 ("}", s5) <- lex s4 92 return (Join x, s5) 93 94instance Show2 p => Show1 (Join p) where 95 liftShowsPrec sp1 sl1 p (Join x) = showParen (p > 10) $ 96 showString "Join {runJoin = " 97 . liftShowsPrec2 sp1 sl1 sp1 sl1 0 x 98 . showChar '}' 99#endif 100 101instance Bifunctor p => Functor (Join p) where 102 fmap f (Join a) = Join (bimap f f a) 103 {-# INLINE fmap #-} 104 105instance Biapplicative p => Applicative (Join p) where 106 pure a = Join (bipure a a) 107 {-# INLINE pure #-} 108 Join f <*> Join a = Join (f <<*>> a) 109 {-# INLINE (<*>) #-} 110 Join a *> Join b = Join (a *>> b) 111 {-# INLINE (*>) #-} 112 Join a <* Join b = Join (a <<* b) 113 {-# INLINE (<*) #-} 114 115instance Bifoldable p => Foldable (Join p) where 116 foldMap f (Join a) = bifoldMap f f a 117 {-# INLINE foldMap #-} 118 119instance Bitraversable p => Traversable (Join p) where 120 traverse f (Join a) = fmap Join (bitraverse f f a) 121 {-# INLINE traverse #-} 122 sequenceA (Join a) = fmap Join (bisequenceA a) 123 {-# INLINE sequenceA #-} 124