module Data.Bifunctor.Assoc (
    Assoc (..),
    ) where

import Control.Applicative    (Const (..))
import Data.Bifunctor         (Bifunctor (..))
import Data.Bifunctor.Flip    (Flip (..))
import Data.Bifunctor.Product (Product (..))
import Data.Bifunctor.Tannen  (Tannen (..))
import Data.Tagged            (Tagged (..))

-- | "Semigroup-y" 'Bifunctor's.
--
-- @
-- 'assoc' . 'unassoc' = 'id'
-- 'unassoc' . 'assoc' = 'id'
-- 'assoc' . 'bimap' ('bimap' f g) h = 'bimap' f ('bimap' g h) . 'assoc'
-- @
--
-- This library doesn't provide @Monoidal@ class, with left and right unitors.
-- Are they useful in practice?
--
class Bifunctor p => Assoc p where
    assoc :: p (p a b) c -> p a (p b c)
    unassoc :: p a (p b c) -> p (p a b) c

instance Assoc (,) where
    assoc :: ((a, b), c) -> (a, (b, c))
assoc ((a
a, b
b), c
c) = (a
a, (b
b, c
c))
    unassoc :: (a, (b, c)) -> ((a, b), c)
unassoc (a
a, (b
b, c
c)) = ((a
a, b
b), c
c)

instance Assoc Either where
    assoc :: Either (Either a b) c -> Either a (Either b c)
assoc (Left (Left a
a))  = a -> Either a (Either b c)
forall a b. a -> Either a b
Left a
a
    assoc (Left (Right b
b)) = Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (b -> Either b c
forall a b. a -> Either a b
Left b
b)
    assoc (Right c
c)        = Either b c -> Either a (Either b c)
forall a b. b -> Either a b
Right (c -> Either b c
forall a b. b -> Either a b
Right c
c)

    unassoc :: Either a (Either b c) -> Either (Either a b) c
unassoc (Left a
a)          = Either a b -> Either (Either a b) c
forall a b. a -> Either a b
Left (a -> Either a b
forall a b. a -> Either a b
Left a
a)
    unassoc (Right (Left b
b))  = Either a b -> Either (Either a b) c
forall a b. a -> Either a b
Left (b -> Either a b
forall a b. b -> Either a b
Right b
b)
    unassoc (Right (Right c
c)) = c -> Either (Either a b) c
forall a b. b -> Either a b
Right c
c

instance Assoc Const where
    assoc :: Const (Const a b) c -> Const a (Const b c)
assoc (Const (Const a
a)) = a -> Const a (Const b c)
forall k a (b :: k). a -> Const a b
Const a
a
    unassoc :: Const a (Const b c) -> Const (Const a b) c
unassoc (Const a
a) = Const a b -> Const (Const a b) c
forall k a (b :: k). a -> Const a b
Const (a -> Const a b
forall k a (b :: k). a -> Const a b
Const a
a)

instance Assoc Tagged where
    assoc :: Tagged (Tagged a b) c -> Tagged a (Tagged b c)
assoc (Tagged c
a) = Tagged b c -> Tagged a (Tagged b c)
forall k (s :: k) b. b -> Tagged s b
Tagged (c -> Tagged b c
forall k (s :: k) b. b -> Tagged s b
Tagged c
a)
    unassoc :: Tagged a (Tagged b c) -> Tagged (Tagged a b) c
unassoc (Tagged (Tagged c
a)) = c -> Tagged (Tagged a b) c
forall k (s :: k) b. b -> Tagged s b
Tagged c
a

instance Assoc p => Assoc (Flip p) where
    assoc :: Flip p (Flip p a b) c -> Flip p a (Flip p b c)
assoc   = p (Flip p b c) a -> Flip p a (Flip p b c)
forall k k1 (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip (p (Flip p b c) a -> Flip p a (Flip p b c))
-> (Flip p (Flip p a b) c -> p (Flip p b c) a)
-> Flip p (Flip p a b) c
-> Flip p a (Flip p b c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p c b -> Flip p b c) -> p (p c b) a -> p (Flip p b c) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first p c b -> Flip p b c
forall k k1 (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip (p (p c b) a -> p (Flip p b c) a)
-> (Flip p (Flip p a b) c -> p (p c b) a)
-> Flip p (Flip p a b) c
-> p (Flip p b c) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p c (p b a) -> p (p c b) a
forall (p :: * -> * -> *) a b c.
Assoc p =>
p a (p b c) -> p (p a b) c
unassoc (p c (p b a) -> p (p c b) a)
-> (Flip p (Flip p a b) c -> p c (p b a))
-> Flip p (Flip p a b) c
-> p (p c b) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flip p a b -> p b a) -> p c (Flip p a b) -> p c (p b a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Flip p a b -> p b a
forall k1 k2 (p :: k2 -> k1 -> *) (a :: k1) (b :: k2).
Flip p a b -> p b a
runFlip (p c (Flip p a b) -> p c (p b a))
-> (Flip p (Flip p a b) c -> p c (Flip p a b))
-> Flip p (Flip p a b) c
-> p c (p b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip p (Flip p a b) c -> p c (Flip p a b)
forall k1 k2 (p :: k2 -> k1 -> *) (a :: k1) (b :: k2).
Flip p a b -> p b a
runFlip
    unassoc :: Flip p a (Flip p b c) -> Flip p (Flip p a b) c
unassoc = p c (Flip p a b) -> Flip p (Flip p a b) c
forall k k1 (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip (p c (Flip p a b) -> Flip p (Flip p a b) c)
-> (Flip p a (Flip p b c) -> p c (Flip p a b))
-> Flip p a (Flip p b c)
-> Flip p (Flip p a b) c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p b a -> Flip p a b) -> p c (p b a) -> p c (Flip p a b)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second p b a -> Flip p a b
forall k k1 (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip (p c (p b a) -> p c (Flip p a b))
-> (Flip p a (Flip p b c) -> p c (p b a))
-> Flip p a (Flip p b c)
-> p c (Flip p a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (p c b) a -> p c (p b a)
forall (p :: * -> * -> *) a b c.
Assoc p =>
p (p a b) c -> p a (p b c)
assoc (p (p c b) a -> p c (p b a))
-> (Flip p a (Flip p b c) -> p (p c b) a)
-> Flip p a (Flip p b c)
-> p c (p b a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Flip p b c -> p c b) -> p (Flip p b c) a -> p (p c b) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Flip p b c -> p c b
forall k1 k2 (p :: k2 -> k1 -> *) (a :: k1) (b :: k2).
Flip p a b -> p b a
runFlip (p (Flip p b c) a -> p (p c b) a)
-> (Flip p a (Flip p b c) -> p (Flip p b c) a)
-> Flip p a (Flip p b c)
-> p (p c b) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip p a (Flip p b c) -> p (Flip p b c) a
forall k1 k2 (p :: k2 -> k1 -> *) (a :: k1) (b :: k2).
Flip p a b -> p b a
runFlip

-- $setup
--
-- TODO: make proper test-suite
--
-- >>> import Data.Proxy
-- >>> import Test.QuickCheck
-- >>> import Test.QuickCheck.Instances
-- >>> import Data.Functor.Classes
--
-- >>> :{
--     let assocUnassocLaw :: (Assoc p, Eq2 p) => Proxy p -> p Bool (p Int Char) -> Bool
--         assocUnassocLaw _ x = liftEq2 (==) eq2 (assoc (unassoc x)) x
--     :}
--
-- >>> quickCheck $ assocUnassocLaw (Proxy :: Proxy (,))
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ assocUnassocLaw (Proxy :: Proxy Either)
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ assocUnassocLaw (Proxy :: Proxy Tagged)
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ assocUnassocLaw (Proxy :: Proxy Const)
-- +++ OK, passed 100 tests.
--
-- >>> :{
--     let unassocAssocLaw :: (Assoc p, Eq2 p) => Proxy p -> p (p Int Char) Bool -> Bool
--         unassocAssocLaw _ x = liftEq2 eq2 (==) (unassoc (assoc x)) x
--     :}
--
-- >>> quickCheck $ unassocAssocLaw (Proxy :: Proxy (,))
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ unassocAssocLaw (Proxy :: Proxy Either)
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ unassocAssocLaw (Proxy :: Proxy Tagged)
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ unassocAssocLaw (Proxy :: Proxy Const)
-- +++ OK, passed 100 tests.
--
-- >>> :{
--     let bimapLaw :: (Assoc p, Eq2 p) => Proxy p
--                  -> Fun Int Char -> Fun Char Bool -> Fun Bool Int
--                  -> p (p Int Char) Bool
--                  -> Bool
--         bimapLaw _ (Fun _ f) (Fun _ g) (Fun _ h) x = liftEq2 (==) eq2
--             (assoc . bimap (bimap f g) h $ x)
--             (bimap f (bimap g h) . assoc $ x)
--     :}
--
-- >>> quickCheck $ bimapLaw (Proxy :: Proxy (,))
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ bimapLaw (Proxy :: Proxy Either)
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ bimapLaw (Proxy :: Proxy Tagged)
-- +++ OK, passed 100 tests.
--
-- >>> quickCheck $ bimapLaw (Proxy :: Proxy Const)
-- +++ OK, passed 100 tests.