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 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-- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\" 31-- by Conor McBride. 32---------------------------------------------------------------------------- 33module Data.Bifunctor.Clown 34 ( Clown(..) 35 ) where 36 37#if __GLASGOW_HASKELL__ < 710 38import Control.Applicative 39#endif 40 41import Data.Biapplicative 42import Data.Bifoldable 43import Data.Bitraversable 44import Data.Functor.Classes 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-- | Make a 'Functor' over the first argument of a 'Bifunctor'. 61-- 62-- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), 63-- joke__r__s to the __r__ight. 64newtype Clown f a b = Clown { runClown :: f a } 65 deriving ( Eq, Ord, Show, Read 66#if __GLASGOW_HASKELL__ >= 702 67 , Generic 68#endif 69#if __GLASGOW_HASKELL__ >= 708 70 , Generic1 71 , Typeable 72#endif 73 ) 74 75#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 76data ClownMetaData 77data ClownMetaCons 78data ClownMetaSel 79 80instance Datatype ClownMetaData where 81 datatypeName _ = "Clown" 82 moduleName _ = "Data.Bifunctor.Clown" 83 84instance Constructor ClownMetaCons where 85 conName _ = "Clown" 86 conIsRecord _ = True 87 88instance Selector ClownMetaSel where 89 selName _ = "runClown" 90 91instance Generic1 (Clown f a) where 92 type Rep1 (Clown f a) = D1 ClownMetaData (C1 ClownMetaCons 93 (S1 ClownMetaSel (Rec0 (f a)))) 94 from1 = M1 . M1 . M1 . K1 . runClown 95 to1 = Clown . unK1 . unM1 . unM1 . unM1 96#endif 97 98#if LIFTED_FUNCTOR_CLASSES 99instance (Eq1 f, Eq a) => Eq1 (Clown f a) where 100 liftEq = liftEq2 (==) 101instance Eq1 f => Eq2 (Clown f) where 102 liftEq2 f _ = eqClown (liftEq f) 103 104instance (Ord1 f, Ord a) => Ord1 (Clown f a) where 105 liftCompare = liftCompare2 compare 106instance Ord1 f => Ord2 (Clown f) where 107 liftCompare2 f _ = compareClown (liftCompare f) 108 109instance (Read1 f, Read a) => Read1 (Clown f a) where 110 liftReadsPrec = liftReadsPrec2 readsPrec readList 111instance Read1 f => Read2 (Clown f) where 112 liftReadsPrec2 rp1 rl1 _ _ = readsPrecClown (liftReadsPrec rp1 rl1) 113 114instance (Show1 f, Show a) => Show1 (Clown f a) where 115 liftShowsPrec = liftShowsPrec2 showsPrec showList 116instance Show1 f => Show2 (Clown f) where 117 liftShowsPrec2 sp1 sl1 _ _ = showsPrecClown (liftShowsPrec sp1 sl1) 118#else 119instance (Eq1 f, Eq a) => Eq1 (Clown f a) where 120 eq1 = eqClown eq1 121 122instance (Ord1 f, Ord a) => Ord1 (Clown f a) where 123 compare1 = compareClown compare1 124 125instance (Read1 f, Read a) => Read1 (Clown f a) where 126 readsPrec1 = readsPrecClown readsPrec1 127 128instance (Show1 f, Show a) => Show1 (Clown f a) where 129 showsPrec1 = showsPrecClown showsPrec1 130#endif 131 132eqClown :: (f a1 -> f a2 -> Bool) 133 -> Clown f a1 b1 -> Clown f a2 b2 -> Bool 134eqClown eqA (Clown x) (Clown y) = eqA x y 135 136compareClown :: (f a1 -> f a2 -> Ordering) 137 -> Clown f a1 b1 -> Clown f a2 b2 -> Ordering 138compareClown compareA (Clown x) (Clown y) = compareA x y 139 140readsPrecClown :: (Int -> ReadS (f a)) 141 -> Int -> ReadS (Clown f a b) 142readsPrecClown rpA p = 143 readParen (p > 10) $ \s0 -> do 144 ("Clown", s1) <- lex s0 145 ("{", s2) <- lex s1 146 ("runClown", s3) <- lex s2 147 (x, s4) <- rpA 0 s3 148 ("}", s5) <- lex s4 149 return (Clown x, s5) 150 151showsPrecClown :: (Int -> f a -> ShowS) 152 -> Int -> Clown f a b -> ShowS 153showsPrecClown spA p (Clown x) = 154 showParen (p > 10) $ 155 showString "Clown {runClown = " 156 . spA 0 x 157 . showChar '}' 158 159instance Functor f => Bifunctor (Clown f) where 160 first f = Clown . fmap f . runClown 161 {-# INLINE first #-} 162 second _ = Clown . runClown 163 {-# INLINE second #-} 164 bimap f _ = Clown . fmap f . runClown 165 {-# INLINE bimap #-} 166 167instance Functor (Clown f a) where 168 fmap _ = Clown . runClown 169 {-# INLINE fmap #-} 170 171instance Applicative f => Biapplicative (Clown f) where 172 bipure a _ = Clown (pure a) 173 {-# INLINE bipure #-} 174 175 Clown mf <<*>> Clown mx = Clown (mf <*> mx) 176 {-# INLINE (<<*>>) #-} 177 178instance Foldable f => Bifoldable (Clown f) where 179 bifoldMap f _ = foldMap f . runClown 180 {-# INLINE bifoldMap #-} 181 182instance Foldable (Clown f a) where 183 foldMap _ = mempty 184 {-# INLINE foldMap #-} 185 186instance Traversable f => Bitraversable (Clown f) where 187 bitraverse f _ = fmap Clown . traverse f . runClown 188 {-# INLINE bitraverse #-} 189 190instance Traversable (Clown f a) where 191 traverse _ = pure . Clown . runClown 192 {-# INLINE traverse #-} 193