{-
A simple homogeneous pair type with useful Functor, Applicative, and
Traversable instances.
-}

{-# LANGUAGE CPP #-}

module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where

#include "HsVersions.h"

import GhcPrelude

import Outputable
import qualified Data.Semigroup as Semi

data Pair a = Pair { Pair a -> a
pFst :: a, Pair a -> a
pSnd :: a }
-- Note that Pair is a *unary* type constructor
-- whereas (,) is binary

-- The important thing about Pair is that it has a *homogeneous*
-- Functor instance, so you can easily apply the same function
-- to both components
instance Functor Pair where
  fmap :: (a -> b) -> Pair a -> Pair b
fmap f :: a -> b
f (Pair x :: a
x y :: a
y) = b -> b -> Pair b
forall a. a -> a -> Pair a
Pair (a -> b
f a
x) (a -> b
f a
y)

instance Applicative Pair where
  pure :: a -> Pair a
pure x :: a
x = a -> a -> Pair a
forall a. a -> a -> Pair a
Pair a
x a
x
  (Pair f :: a -> b
f g :: a -> b
g) <*> :: Pair (a -> b) -> Pair a -> Pair b
<*> (Pair x :: a
x y :: a
y) = b -> b -> Pair b
forall a. a -> a -> Pair a
Pair (a -> b
f a
x) (a -> b
g a
y)

instance Foldable Pair where
  foldMap :: (a -> m) -> Pair a -> m
foldMap f :: a -> m
f (Pair x :: a
x y :: a
y) = a -> m
f a
x m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
y

instance Traversable Pair where
  traverse :: (a -> f b) -> Pair a -> f (Pair b)
traverse f :: a -> f b
f (Pair x :: a
x y :: a
y) = b -> b -> Pair b
forall a. a -> a -> Pair a
Pair (b -> b -> Pair b) -> f b -> f (b -> Pair b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x f (b -> Pair b) -> f b -> f (Pair b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
y

instance Semi.Semigroup a => Semi.Semigroup (Pair a) where
  Pair a1 :: a
a1 b1 :: a
b1 <> :: Pair a -> Pair a -> Pair a
<> Pair a2 :: a
a2 b2 :: a
b2 =  a -> a -> Pair a
forall a. a -> a -> Pair a
Pair (a
a1 a -> a -> a
forall a. Semigroup a => a -> a -> a
Semi.<> a
a2) (a
b1 a -> a -> a
forall a. Semigroup a => a -> a -> a
Semi.<> a
b2)

instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where
  mempty :: Pair a
mempty = a -> a -> Pair a
forall a. a -> a -> Pair a
Pair a
forall a. Monoid a => a
mempty a
forall a. Monoid a => a
mempty
  mappend :: Pair a -> Pair a -> Pair a
mappend = Pair a -> Pair a -> Pair a
forall a. Semigroup a => a -> a -> a
(Semi.<>)

instance Outputable a => Outputable (Pair a) where
  ppr :: Pair a -> SDoc
ppr (Pair a :: a
a b :: a
b) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
a SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char '~' SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
b

unPair :: Pair a -> (a,a)
unPair :: Pair a -> (a, a)
unPair (Pair x :: a
x y :: a
y) = (a
x,a
y)

toPair :: (a,a) -> Pair a
toPair :: (a, a) -> Pair a
toPair (x :: a
x,y :: a
y) = a -> a -> Pair a
forall a. a -> a -> Pair a
Pair a
x a
y

swap :: Pair a -> Pair a
swap :: Pair a -> Pair a
swap (Pair x :: a
x y :: a
y) = a -> a -> Pair a
forall a. a -> a -> Pair a
Pair a
y a
x

pLiftFst :: (a -> a) -> Pair a -> Pair a
pLiftFst :: (a -> a) -> Pair a -> Pair a
pLiftFst f :: a -> a
f (Pair a :: a
a b :: a
b) = a -> a -> Pair a
forall a. a -> a -> Pair a
Pair (a -> a
f a
a) a
b

pLiftSnd :: (a -> a) -> Pair a -> Pair a
pLiftSnd :: (a -> a) -> Pair a -> Pair a
pLiftSnd f :: a -> a
f (Pair a :: a
a b :: a
b) = a -> a -> Pair a
forall a. a -> a -> Pair a
Pair a
a (a -> a
f a
b)