{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Data.Bifunctor.Join
  ( Join(..)
  ) 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 both arguments of a 'Bifunctor'.
newtype Join p a = Join { forall {k} (p :: k -> k -> *) (a :: k). Join p a -> p a a
runJoin :: p a a }
  deriving (forall x. Join p a -> Rep (Join p a) x)
-> (forall x. Rep (Join p a) x -> Join p a) -> Generic (Join p a)
forall x. Rep (Join p a) x -> Join p a
forall x. Join p a -> Rep (Join p a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (p :: k -> k -> *) (a :: k) x.
Rep (Join p a) x -> Join p a
forall k (p :: k -> k -> *) (a :: k) x.
Join p a -> Rep (Join p a) x
$cfrom :: forall k (p :: k -> k -> *) (a :: k) x.
Join p a -> Rep (Join p a) x
from :: forall x. Join p a -> Rep (Join p a) x
$cto :: forall k (p :: k -> k -> *) (a :: k) x.
Rep (Join p a) x -> Join p a
to :: forall x. Rep (Join p a) x -> Join p a
Generic

deriving instance Eq   (p a a) => Eq   (Join p a)
deriving instance Ord  (p a a) => Ord  (Join p a)
deriving instance Show (p a a) => Show (Join p a)
deriving instance Read (p a a) => Read (Join p a)

instance Eq2 p => Eq1 (Join p) where
  liftEq :: forall a b. (a -> b -> Bool) -> Join p a -> Join p b -> Bool
liftEq a -> b -> Bool
f (Join p a a
x) (Join p b b
y) = (a -> b -> Bool) -> (a -> b -> Bool) -> p a a -> p b b -> Bool
forall a b c d.
(a -> b -> Bool) -> (c -> d -> Bool) -> p a c -> p b d -> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 a -> b -> Bool
f a -> b -> Bool
f p a a
x p b b
y

instance Ord2 p => Ord1 (Join p) where
  liftCompare :: forall a b.
(a -> b -> Ordering) -> Join p a -> Join p b -> Ordering
liftCompare a -> b -> Ordering
f (Join p a a
x) (Join p b b
y) = (a -> b -> Ordering)
-> (a -> b -> Ordering) -> p a a -> p b b -> Ordering
forall a b c d.
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> p a c -> p b d -> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 a -> b -> Ordering
f a -> b -> Ordering
f p a a
x p b b
y

instance Read2 p => Read1 (Join p) where
  liftReadsPrec :: forall a. (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Join p a)
liftReadsPrec Int -> ReadS a
rp1 ReadS [a]
rl1 Int
p = Bool -> ReadS (Join p a) -> ReadS (Join p a)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ReadS (Join p a) -> ReadS (Join p a))
-> ReadS (Join p a) -> ReadS (Join p a)
forall a b. (a -> b) -> a -> b
$ \String
s0 -> do
    (String
"Join",    String
s1) <- ReadS String
lex String
s0
    (String
"{",       String
s2) <- ReadS String
lex String
s1
    (String
"runJoin", String
s3) <- ReadS String
lex String
s2
    (p a a
x,         String
s4) <- (Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (p a a)
forall a b.
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (p a b)
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 Int -> ReadS a
rp1 ReadS [a]
rl1 Int -> ReadS a
rp1 ReadS [a]
rl1 Int
0 String
s3
    (String
"}",       String
s5) <- ReadS String
lex String
s4
    (Join p a, String) -> [(Join p a, String)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (p a a -> Join p a
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join p a a
x, String
s5)

instance Show2 p => Show1 (Join p) where
  liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Join p a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int
p (Join p a a
x) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"Join {runJoin = "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> p a a
-> ShowS
forall a b.
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> p a b
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int
0 p a a
x
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'

instance Bifunctor p => Functor (Join p) where
  fmap :: forall a b. (a -> b) -> Join p a -> Join p b
fmap a -> b
f (Join p a a
a) = p b b -> Join p b
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join ((a -> b) -> (a -> b) -> p a a -> p b b
forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f a -> b
f p a a
a)
  {-# INLINE fmap #-}

instance Biapplicative p => Applicative (Join p) where
  pure :: forall a. a -> Join p a
pure a
a = p a a -> Join p a
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join (a -> a -> p a a
forall a b. a -> b -> p a b
forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure a
a a
a)
  {-# INLINE pure #-}
  Join p (a -> b) (a -> b)
f <*> :: forall a b. Join p (a -> b) -> Join p a -> Join p b
<*> Join p a a
a = p b b -> Join p b
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join (p (a -> b) (a -> b)
f p (a -> b) (a -> b) -> p a a -> p b b
forall a b c d. p (a -> b) (c -> d) -> p a c -> p b d
forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p (a -> b) (c -> d) -> p a c -> p b d
<<*>> p a a
a)
  {-# INLINE (<*>) #-}
  Join p a a
a *> :: forall a b. Join p a -> Join p b -> Join p b
*> Join p b b
b = p b b -> Join p b
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join (p a a
a p a a -> p b b -> p b b
forall a b c d. p a b -> p c d -> p c d
forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p a b -> p c d -> p c d
*>> p b b
b)
  {-# INLINE (*>) #-}
  Join p a a
a <* :: forall a b. Join p a -> Join p b -> Join p a
<* Join p b b
b = p a a -> Join p a
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join (p a a
a p a a -> p b b -> p a a
forall a b c d. p a b -> p c d -> p a b
forall (p :: * -> * -> *) a b c d.
Biapplicative p =>
p a b -> p c d -> p a b
<<* p b b
b)
  {-# INLINE (<*) #-}

instance Bifoldable p => Foldable (Join p) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Join p a -> m
foldMap a -> m
f (Join p a a
a) = (a -> m) -> (a -> m) -> p a a -> m
forall m a b. Monoid m => (a -> m) -> (b -> m) -> p a b -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f a -> m
f p a a
a
  {-# INLINE foldMap #-}

instance Bifoldable1 p => Foldable1 (Join p) where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> Join p a -> m
foldMap1 a -> m
f (Join p a a
a) = (a -> m) -> (a -> m) -> p a a -> m
forall m a b. Semigroup m => (a -> m) -> (b -> m) -> p a b -> m
forall (t :: * -> * -> *) m a b.
(Bifoldable1 t, Semigroup m) =>
(a -> m) -> (b -> m) -> t a b -> m
bifoldMap1 a -> m
f a -> m
f p a a
a
  {-# INLINE foldMap1 #-}

instance Bitraversable p => Traversable (Join p) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Join p a -> f (Join p b)
traverse a -> f b
f (Join p a a
a) = (p b b -> Join p b) -> f (p b b) -> f (Join p b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap p b b -> Join p b
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join ((a -> f b) -> (a -> f b) -> p a a -> f (p b b)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> p a b -> f (p c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f b
f a -> f b
f p a a
a)
  {-# INLINE traverse #-}
  sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Join p (f a) -> f (Join p a)
sequenceA (Join p (f a) (f a)
a) = (p a a -> Join p a) -> f (p a a) -> f (Join p a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap p a a -> Join p a
forall {k} (p :: k -> k -> *) (a :: k). p a a -> Join p a
Join (p (f a) (f a) -> f (p a a)
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequenceA p (f a) (f a)
a)
  {-# INLINE sequenceA #-}