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 :: forall a b c. ((a, b), c) -> (a, (b, c))
assoc ((a
a, b
b), c
c) = (a
a, (b
b, c
c))
    unassoc :: forall a b c. (a, (b, c)) -> ((a, b), c)
unassoc (a
a, (b
b, c
c)) = ((a
a, b
b), c
c)

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

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

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

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

instance Assoc p => Assoc (Flip p) where
    assoc :: forall a b c. Flip p (Flip p a b) c -> Flip p a (Flip p b c)
assoc   = forall {k} {k1} (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {k} {k1} (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Assoc p =>
p a (p b c) -> p (p a b) c
unassoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall {k1} {k2} (p :: k1 -> k2 -> *) (a :: k2) (b :: k1).
Flip p a b -> p b a
runFlip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (p :: k1 -> k2 -> *) (a :: k2) (b :: k1).
Flip p a b -> p b a
runFlip
    unassoc :: forall a b c. Flip p a (Flip p b c) -> Flip p (Flip p a b) c
unassoc = forall {k} {k1} (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall {k} {k1} (p :: k -> k1 -> *) (a :: k1) (b :: k).
p b a -> Flip p a b
Flip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Assoc p =>
p (p a b) c -> p a (p b c)
assoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {k1} {k2} (p :: k1 -> k2 -> *) (a :: k2) (b :: k1).
Flip p a b -> p b a
runFlip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} (p :: k1 -> k2 -> *) (a :: k2) (b :: k1).
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.