{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- From the Functional Pearl \"Clowns to the Left of me, Jokers to the Right: Dissecting Data Structures\"
-- by Conor McBride.
----------------------------------------------------------------------------
module Data.Bifunctor.Joker
  ( Joker(..)
  ) where

import Data.Biapplicative
import Data.Bifoldable
import Data.Bifoldable1 (Bifoldable1(..))
import Data.Bitraversable
import Data.Foldable1 (Foldable1(..))
import Data.Functor.Classes
import GHC.Generics

-- | Make a 'Functor' over the second argument of a 'Bifunctor'.
--
-- Mnemonic: C__l__owns to the __l__eft (parameter of the Bifunctor),
--           joke__r__s to the __r__ight.
newtype Joker g a b = Joker { forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker :: g b }
  deriving (Joker g a b -> Joker g a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (g :: k -> *) k (a :: k) (b :: k).
Eq (g b) =>
Joker g a b -> Joker g a b -> Bool
/= :: Joker g a b -> Joker g a b -> Bool
$c/= :: forall k (g :: k -> *) k (a :: k) (b :: k).
Eq (g b) =>
Joker g a b -> Joker g a b -> Bool
== :: Joker g a b -> Joker g a b -> Bool
$c== :: forall k (g :: k -> *) k (a :: k) (b :: k).
Eq (g b) =>
Joker g a b -> Joker g a b -> Bool
Eq, Joker g a b -> Joker g a b -> Bool
Joker g a b -> Joker g a b -> Ordering
Joker g a b -> Joker g a b -> Joker g a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {k} {g :: k -> *} {k} {a :: k} {b :: k}.
Ord (g b) =>
Eq (Joker g a b)
forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Bool
forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Ordering
forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Joker g a b
min :: Joker g a b -> Joker g a b -> Joker g a b
$cmin :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Joker g a b
max :: Joker g a b -> Joker g a b -> Joker g a b
$cmax :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Joker g a b
>= :: Joker g a b -> Joker g a b -> Bool
$c>= :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Bool
> :: Joker g a b -> Joker g a b -> Bool
$c> :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Bool
<= :: Joker g a b -> Joker g a b -> Bool
$c<= :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Bool
< :: Joker g a b -> Joker g a b -> Bool
$c< :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Bool
compare :: Joker g a b -> Joker g a b -> Ordering
$ccompare :: forall k (g :: k -> *) k (a :: k) (b :: k).
Ord (g b) =>
Joker g a b -> Joker g a b -> Ordering
Ord, Int -> Joker g a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (g :: k -> *) k (a :: k) (b :: k).
Show (g b) =>
Int -> Joker g a b -> ShowS
forall k (g :: k -> *) k (a :: k) (b :: k).
Show (g b) =>
[Joker g a b] -> ShowS
forall k (g :: k -> *) k (a :: k) (b :: k).
Show (g b) =>
Joker g a b -> String
showList :: [Joker g a b] -> ShowS
$cshowList :: forall k (g :: k -> *) k (a :: k) (b :: k).
Show (g b) =>
[Joker g a b] -> ShowS
show :: Joker g a b -> String
$cshow :: forall k (g :: k -> *) k (a :: k) (b :: k).
Show (g b) =>
Joker g a b -> String
showsPrec :: Int -> Joker g a b -> ShowS
$cshowsPrec :: forall k (g :: k -> *) k (a :: k) (b :: k).
Show (g b) =>
Int -> Joker g a b -> ShowS
Show, ReadPrec [Joker g a b]
ReadPrec (Joker g a b)
ReadS [Joker g a b]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
ReadPrec [Joker g a b]
forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
ReadPrec (Joker g a b)
forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
Int -> ReadS (Joker g a b)
forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
ReadS [Joker g a b]
readListPrec :: ReadPrec [Joker g a b]
$creadListPrec :: forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
ReadPrec [Joker g a b]
readPrec :: ReadPrec (Joker g a b)
$creadPrec :: forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
ReadPrec (Joker g a b)
readList :: ReadS [Joker g a b]
$creadList :: forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
ReadS [Joker g a b]
readsPrec :: Int -> ReadS (Joker g a b)
$creadsPrec :: forall k (g :: k -> *) k (a :: k) (b :: k).
Read (g b) =>
Int -> ReadS (Joker g a b)
Read, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (g :: k -> *) k (a :: k) (b :: k) x.
Rep (Joker g a b) x -> Joker g a b
forall k (g :: k -> *) k (a :: k) (b :: k) x.
Joker g a b -> Rep (Joker g a b) x
$cto :: forall k (g :: k -> *) k (a :: k) (b :: k) x.
Rep (Joker g a b) x -> Joker g a b
$cfrom :: forall k (g :: k -> *) k (a :: k) (b :: k) x.
Joker g a b -> Rep (Joker g a b) x
Generic, forall k (f :: k -> *).
(forall (a :: k). f a -> Rep1 f a)
-> (forall (a :: k). Rep1 f a -> f a) -> Generic1 f
forall k (g :: k -> *) k (a :: k) (a :: k).
Rep1 (Joker g a) a -> Joker g a a
forall k (g :: k -> *) k (a :: k) (a :: k).
Joker g a a -> Rep1 (Joker g a) a
$cto1 :: forall k (g :: k -> *) k (a :: k) (a :: k).
Rep1 (Joker g a) a -> Joker g a a
$cfrom1 :: forall k (g :: k -> *) k (a :: k) (a :: k).
Joker g a a -> Rep1 (Joker g a) a
Generic1)

instance Eq1 g => Eq1 (Joker g a) where
  liftEq :: forall a b. (a -> b -> Bool) -> Joker g a a -> Joker g a b -> Bool
liftEq a -> b -> Bool
g = forall {k} {k} {k} (g :: k -> *) (b1 :: k) (b2 :: k) (a1 :: k)
       (a2 :: k).
(g b1 -> g b2 -> Bool) -> Joker g a1 b1 -> Joker g a2 b2 -> Bool
eqJoker (forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
g)
instance Eq1 g => Eq2 (Joker g) where
  liftEq2 :: forall a b c d.
(a -> b -> Bool)
-> (c -> d -> Bool) -> Joker g a c -> Joker g b d -> Bool
liftEq2 a -> b -> Bool
_ c -> d -> Bool
g = forall {k} {k} {k} (g :: k -> *) (b1 :: k) (b2 :: k) (a1 :: k)
       (a2 :: k).
(g b1 -> g b2 -> Bool) -> Joker g a1 b1 -> Joker g a2 b2 -> Bool
eqJoker (forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq c -> d -> Bool
g)

instance Ord1 g => Ord1 (Joker g a) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> Joker g a a -> Joker g a b -> Ordering
liftCompare a -> b -> Ordering
g = forall {k} {k} {k} (g :: k -> *) (b1 :: k) (b2 :: k) (a1 :: k)
       (a2 :: k).
(g b1 -> g b2 -> Ordering)
-> Joker g a1 b1 -> Joker g a2 b2 -> Ordering
compareJoker (forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
g)
instance Ord1 g => Ord2 (Joker g) where
  liftCompare2 :: forall a b c d.
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> Joker g a c -> Joker g b d -> Ordering
liftCompare2 a -> b -> Ordering
_ c -> d -> Ordering
g = forall {k} {k} {k} (g :: k -> *) (b1 :: k) (b2 :: k) (a1 :: k)
       (a2 :: k).
(g b1 -> g b2 -> Ordering)
-> Joker g a1 b1 -> Joker g a2 b2 -> Ordering
compareJoker (forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare c -> d -> Ordering
g)

instance Read1 g => Read1 (Joker g a) where
  liftReadsPrec :: forall a.
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Joker g a a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl = forall {k} {k} (g :: k -> *) (b :: k) (a :: k).
(Int -> ReadS (g b)) -> Int -> ReadS (Joker g a b)
readsPrecJoker (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl)
instance Read1 g => Read2 (Joker g) where
  liftReadsPrec2 :: forall a b.
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (Joker g a b)
liftReadsPrec2 Int -> ReadS a
_ ReadS [a]
_ Int -> ReadS b
rp2 ReadS [b]
rl2 = forall {k} {k} (g :: k -> *) (b :: k) (a :: k).
(Int -> ReadS (g b)) -> Int -> ReadS (Joker g a b)
readsPrecJoker (forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS b
rp2 ReadS [b]
rl2)

instance Show1 g => Show1 (Joker g a) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> Joker g a a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl = forall {k} {k} (g :: k -> *) (b :: k) (a :: k).
(Int -> g b -> ShowS) -> Int -> Joker g a b -> ShowS
showsPrecJoker (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl)
instance Show1 g => Show2 (Joker g) where
  liftShowsPrec2 :: forall a b.
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> Joker g a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
_ [a] -> ShowS
_ Int -> b -> ShowS
sp2 [b] -> ShowS
sl2 = forall {k} {k} (g :: k -> *) (b :: k) (a :: k).
(Int -> g b -> ShowS) -> Int -> Joker g a b -> ShowS
showsPrecJoker (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> b -> ShowS
sp2 [b] -> ShowS
sl2)

eqJoker :: (g b1 -> g b2 -> Bool)
        -> Joker g a1 b1 -> Joker g a2 b2 -> Bool
eqJoker :: forall {k} {k} {k} (g :: k -> *) (b1 :: k) (b2 :: k) (a1 :: k)
       (a2 :: k).
(g b1 -> g b2 -> Bool) -> Joker g a1 b1 -> Joker g a2 b2 -> Bool
eqJoker g b1 -> g b2 -> Bool
eqB (Joker g b1
x) (Joker g b2
y) = g b1 -> g b2 -> Bool
eqB g b1
x g b2
y

compareJoker :: (g b1 -> g b2 -> Ordering)
             -> Joker g a1 b1 -> Joker g a2 b2 -> Ordering
compareJoker :: forall {k} {k} {k} (g :: k -> *) (b1 :: k) (b2 :: k) (a1 :: k)
       (a2 :: k).
(g b1 -> g b2 -> Ordering)
-> Joker g a1 b1 -> Joker g a2 b2 -> Ordering
compareJoker g b1 -> g b2 -> Ordering
compareB (Joker g b1
x) (Joker g b2
y) = g b1 -> g b2 -> Ordering
compareB g b1
x g b2
y

readsPrecJoker :: (Int -> ReadS (g b))
               -> Int -> ReadS (Joker g a b)
readsPrecJoker :: forall {k} {k} (g :: k -> *) (b :: k) (a :: k).
(Int -> ReadS (g b)) -> Int -> ReadS (Joker g a b)
readsPrecJoker Int -> ReadS (g b)
rpB Int
p =
  forall a. Bool -> ReadS a -> ReadS a
readParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ \String
s0 -> do
    (String
"Joker",    String
s1) <- ReadS String
lex String
s0
    (String
"{",        String
s2) <- ReadS String
lex String
s1
    (String
"runJoker", String
s3) <- ReadS String
lex String
s2
    (g b
x,          String
s4) <- Int -> ReadS (g b)
rpB Int
0 String
s3
    (String
"}",        String
s5) <- ReadS String
lex String
s4
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker g b
x, String
s5)

showsPrecJoker :: (Int -> g b -> ShowS)
               -> Int -> Joker g a b -> ShowS
showsPrecJoker :: forall {k} {k} (g :: k -> *) (b :: k) (a :: k).
(Int -> g b -> ShowS) -> Int -> Joker g a b -> ShowS
showsPrecJoker Int -> g b -> ShowS
spB Int
p (Joker g b
x) =
  Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"Joker {runJoker = "
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g b -> ShowS
spB Int
0 g b
x
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'

instance Functor g => Bifunctor (Joker g) where
  first :: forall a b c. (a -> b) -> Joker g a c -> Joker g b c
first a -> b
_ = forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE first #-}
  second :: forall b c a. (b -> c) -> Joker g a b -> Joker g a c
second b -> c
g = forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> c
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE second #-}
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Joker g a c -> Joker g b d
bimap a -> b
_ c -> d
g = forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE bimap #-}

instance Functor g => Functor (Joker g a) where
  fmap :: forall a b. (a -> b) -> Joker g a a -> Joker g a b
fmap a -> b
g = forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE fmap #-}

instance Applicative g => Biapplicative (Joker g) where
  bipure :: forall a b. a -> b -> Joker g a b
bipure a
_ b
b = forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker (forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b)
  {-# INLINE bipure #-}

  Joker g (c -> d)
mf <<*>> :: forall a b c d.
Joker g (a -> b) (c -> d) -> Joker g a c -> Joker g b d
<<*>> Joker g c
mx = forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker (g (c -> d)
mf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> g c
mx)
  {-# INLINE (<<*>>) #-}

instance Foldable g => Bifoldable (Joker g) where
  bifoldMap :: forall m a b. Monoid m => (a -> m) -> (b -> m) -> Joker g a b -> m
bifoldMap a -> m
_ b -> m
g = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap b -> m
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE bifoldMap #-}

instance Foldable1 g => Bifoldable1 (Joker g) where
  bifoldMap1 :: forall m a b.
Semigroup m =>
(a -> m) -> (b -> m) -> Joker g a b -> m
bifoldMap1 a -> m
_ b -> m
g = forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 b -> m
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE bifoldMap1 #-}

instance Foldable g => Foldable (Joker g a) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Joker g a a -> m
foldMap a -> m
g = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE foldMap #-}

instance Foldable1 g => Foldable1 (Joker g a) where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> Joker g a a -> m
foldMap1 a -> m
g = forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 a -> m
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE foldMap1 #-}

instance Traversable g => Bitraversable (Joker g) where
  bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Joker g a b -> f (Joker g c d)
bitraverse a -> f c
_ b -> f d
g = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> f d
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE bitraverse #-}

instance Traversable g => Traversable (Joker g a) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Joker g a a -> f (Joker g a b)
traverse a -> f b
g = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} {k} (g :: k -> *) (a :: k) (b :: k). g b -> Joker g a b
Joker forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {k} (g :: k -> *) (a :: k) (b :: k). Joker g a b -> g b
runJoker
  {-# INLINE traverse #-}