{-# 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)) = 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) #ifdef MIN_VERSION_tagged 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 #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.