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