{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >=704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >=702
{-# LANGUAGE Trustworthy #-}
#endif
module Data.Bifunctor.Assoc (
    Assoc (..),
    ) where

import Control.Applicative (Const (..))
import Data.Bifunctor      (Bifunctor (..))

#ifdef MIN_VERSION_tagged
import Data.Tagged         (Tagged (..))
#endif

-- | "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))  = 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 :: forall a b c. 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 :: forall a b c. 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 :: forall a b c. 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)

#ifdef MIN_VERSION_tagged
instance Assoc Tagged where
    assoc (Tagged a) = Tagged (Tagged a)
    unassoc (Tagged (Tagged a)) = Tagged a
#endif

-- $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.