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