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.Joker 34 ( Joker(..) 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.Traversable 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-- | Make a 'Functor' over the second argument of a 'Bifunctor'. 60-- 61-- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor), 62-- joke__r__s to the __r__ight. 63newtype Joker g a b = Joker { runJoker :: g b } 64 deriving ( Eq, Ord, Show, Read 65#if __GLASGOW_HASKELL__ >= 702 66 , Generic 67#endif 68#if __GLASGOW_HASKELL__ >= 708 69 , Generic1 70 , Typeable 71#endif 72 ) 73 74#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 708 75data JokerMetaData 76data JokerMetaCons 77data JokerMetaSel 78 79instance Datatype JokerMetaData where 80 datatypeName _ = "Joker" 81 moduleName _ = "Data.Bifunctor.Joker" 82 83instance Constructor JokerMetaCons where 84 conName _ = "Joker" 85 conIsRecord _ = True 86 87instance Selector JokerMetaSel where 88 selName _ = "runJoker" 89 90instance Generic1 (Joker g a) where 91 type Rep1 (Joker g a) = D1 JokerMetaData (C1 JokerMetaCons 92 (S1 JokerMetaSel (Rec1 g))) 93 from1 = M1 . M1 . M1 . Rec1 . runJoker 94 to1 = Joker . unRec1 . unM1 . unM1 . unM1 95#endif 96 97#if LIFTED_FUNCTOR_CLASSES 98instance Eq1 g => Eq1 (Joker g a) where 99 liftEq g = eqJoker (liftEq g) 100instance Eq1 g => Eq2 (Joker g) where 101 liftEq2 _ g = eqJoker (liftEq g) 102 103instance Ord1 g => Ord1 (Joker g a) where 104 liftCompare g = compareJoker (liftCompare g) 105instance Ord1 g => Ord2 (Joker g) where 106 liftCompare2 _ g = compareJoker (liftCompare g) 107 108instance Read1 g => Read1 (Joker g a) where 109 liftReadsPrec rp rl = readsPrecJoker (liftReadsPrec rp rl) 110instance Read1 g => Read2 (Joker g) where 111 liftReadsPrec2 _ _ rp2 rl2 = readsPrecJoker (liftReadsPrec rp2 rl2) 112 113instance Show1 g => Show1 (Joker g a) where 114 liftShowsPrec sp sl = showsPrecJoker (liftShowsPrec sp sl) 115instance Show1 g => Show2 (Joker g) where 116 liftShowsPrec2 _ _ sp2 sl2 = showsPrecJoker (liftShowsPrec sp2 sl2) 117#else 118instance Eq1 g => Eq1 (Joker g a) where 119 eq1 = eqJoker eq1 120 121instance Ord1 g => Ord1 (Joker g a) where 122 compare1 = compareJoker compare1 123 124instance Read1 g => Read1 (Joker g a) where 125 readsPrec1 = readsPrecJoker readsPrec1 126 127instance Show1 g => Show1 (Joker g a) where 128 showsPrec1 = showsPrecJoker showsPrec1 129#endif 130 131eqJoker :: (g b1 -> g b2 -> Bool) 132 -> Joker g a1 b1 -> Joker g a2 b2 -> Bool 133eqJoker eqB (Joker x) (Joker y) = eqB x y 134 135compareJoker :: (g b1 -> g b2 -> Ordering) 136 -> Joker g a1 b1 -> Joker g a2 b2 -> Ordering 137compareJoker compareB (Joker x) (Joker y) = compareB x y 138 139readsPrecJoker :: (Int -> ReadS (g b)) 140 -> Int -> ReadS (Joker g a b) 141readsPrecJoker rpB p = 142 readParen (p > 10) $ \s0 -> do 143 ("Joker", s1) <- lex s0 144 ("{", s2) <- lex s1 145 ("runJoker", s3) <- lex s2 146 (x, s4) <- rpB 0 s3 147 ("}", s5) <- lex s4 148 return (Joker x, s5) 149 150showsPrecJoker :: (Int -> g b -> ShowS) 151 -> Int -> Joker g a b -> ShowS 152showsPrecJoker spB p (Joker x) = 153 showParen (p > 10) $ 154 showString "Joker {runJoker = " 155 . spB 0 x 156 . showChar '}' 157 158instance Functor g => Bifunctor (Joker g) where 159 first _ = Joker . runJoker 160 {-# INLINE first #-} 161 second g = Joker . fmap g . runJoker 162 {-# INLINE second #-} 163 bimap _ g = Joker . fmap g . runJoker 164 {-# INLINE bimap #-} 165 166instance Functor g => Functor (Joker g a) where 167 fmap g = Joker . fmap g . runJoker 168 {-# INLINE fmap #-} 169 170instance Applicative g => Biapplicative (Joker g) where 171 bipure _ b = Joker (pure b) 172 {-# INLINE bipure #-} 173 174 Joker mf <<*>> Joker mx = Joker (mf <*> mx) 175 {-# INLINE (<<*>>) #-} 176 177instance Foldable g => Bifoldable (Joker g) where 178 bifoldMap _ g = foldMap g . runJoker 179 {-# INLINE bifoldMap #-} 180 181instance Foldable g => Foldable (Joker g a) where 182 foldMap g = foldMap g . runJoker 183 {-# INLINE foldMap #-} 184 185instance Traversable g => Bitraversable (Joker g) where 186 bitraverse _ g = fmap Joker . traverse g . runJoker 187 {-# INLINE bitraverse #-} 188 189instance Traversable g => Traversable (Joker g a) where 190 traverse g = fmap Joker . traverse g . runJoker 191 {-# INLINE traverse #-} 192