{-# LANGUAGE Rank2Types, TypeOperators, FlexibleInstances, FlexibleContexts
           , UndecidableInstances, TypeSynonymInstances #-}

-- -- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}

----------------------------------------------------------------------
-- |
-- Module      :  Data.Pair
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- Portability :  GHC
-- 
-- Pair-related type constructor classes.  See "Data.Fun" for similar classes.
----------------------------------------------------------------------

module Data.Pair
  (
  -- * Pairings
    PairTy, Pair(..)
  , apPair, ppPair, arPair
  -- * Unpairings
  , UnpairTy, Unpair(..)
  -- * Dual unpairings
  , Copair(..), copair
  -- * Misc
  , pairEdit, pairEditM
  ) where


import Data.Monoid
import Control.Arrow
import Control.Applicative
import Control.Monad                    -- for pairEdit

import Control.Compose


{----------------------------------------------------------
    Pairings
----------------------------------------------------------}

-- | Type of 'pair' method
type PairTy f = forall a b. f a -> f b -> f (a,b)

-- | Type constructor class for pair-like things.  Generalizes 'zip'.
-- Here are some standard instance templates you can fill in.  They're not
-- defined in the general forms below, because they would lead to a lot of
-- overlap.
-- 
-- @
--   instance Applicative f => Pair f where
--       pair = liftA2 (,)
--   instance (Applicative h, Pair f) => Pair (h :. f) where
--       pair = apPair
--   instance (Functor g, Pair g, Pair f) => Pair (g :. f)
--       where pair = ppPair
--   instance (Arrow (~>), Unpair f, Pair g) => Pair (Arrw (~>) f g) where
--       pair = arPair
--   instance (Monoid_f h, Copair h) => Pair h where
--       pair = copair
-- @
-- 
-- Also, if you have a type constructor that's a 'Functor' and a 'Pair',
-- here is a way to define '(<*>)' for 'Applicative':
-- 
-- @
--   rf <*> rx = uncurry ($) <$> (rf `pair` rx)
-- @

class Pair f where
  pair :: PairTy f         -- ^ Form a pair-like value (generalizes 'zip')

-- Standard instances (Applicative f)
instance Monoid u => Pair ((,)  u) where pair = liftA2 (,)
instance             Pair ((->) u) where pair = liftA2 (,)
instance             Pair IO       where pair = liftA2 (,)

instance Monoid o => Pair (Const o) where
  pair = inConst2 mappend

instance Pair Id where Id a `pair` Id b = Id (a,b)

-- Standard instance, e.g., (~>) = (->)
-- This one requires UndecidableInstances.  Alternatively, specialize to
-- (->) and other arrows as desired.
instance (Arrow (~>), Monoid_f (Flip (~>) o)) =>
  Pair (Flip (~>) o) where pair = copair

-- | Handy for 'Pair' instances
apPair :: (Applicative h, Pair f) => PairTy (h :. f)
apPair = inO2 (liftA2 pair)

-- | Handy for 'Pair' instances
ppPair :: (Functor g, Pair g, Pair f) => PairTy (g :. f)
ppPair = inO2 $ \ gfa gfb -> fmap (uncurry pair) (gfa `pair` gfb)

-- | Pairing of 'Arrw' values.  /Warning/: definition uses 'arr', so only
-- use if your arrow has a working 'arr'.
arPair :: (Arrow (~>), Unpair f, Pair g) => PairTy (Arrw (~>) f g)
arPair = inArrw2 $ \ fga fgb ->
  arr unpair >>> fga***fgb >>> arr (uncurry pair)

-- Standard instance
instance (Arrow (~>), Unpair f, Pair g) => Pair (Arrw (~>) f g)
  where pair = arPair

instance (Pair f, Pair g) => Pair (f :*: g) where
  pair = inProd2 (pair ***# pair)


{----------------------------------------------------------
    Unpairings
----------------------------------------------------------}

-- | Type of 'unpair' method.  Generalizes 'unzip'.
type UnpairTy f = forall a b. f (a,b) -> (f a, f b)

-- | Dissectable as pairs.  Minimal instance definition: either (a)
-- 'unpair' /or/ (b) both of 'pfst' /and/ 'psnd'.
-- A standard template to substitute any 'Functor' @f.@  But watch out for
-- effects!
-- 
-- @
--   instance Functor f => Unpair f where {pfst = fmap fst; psnd = fmap snd}
-- @
class Unpair f where
  unpair :: UnpairTy f                  -- ^ Deconstruct pair-like value
  pfst   :: f (a,b) -> f a              -- ^ First part of pair-like value
  psnd   :: f (a,b) -> f b              -- ^ Second part of pair-like value

  unpair = pfst &&& psnd
  pfst   = fst.unpair
  psnd   = snd.unpair

instance Unpair (Const a) where
  unpair (Const a) = (Const a, Const a)

instance Unpair Id where
  unpair (Id (a,b)) = (Id a, Id b)

-- Standard instance
instance Unpair [] where { pfst = fmap fst; psnd = fmap snd }


{----------------------------------------------------------
    Dual unpairings
----------------------------------------------------------}

-- | Dual to 'Unpair'.
-- Especially handy for contravariant functors ('Cofunctor') .  Use this
-- template (filling in @f@) :
-- 
-- @
--   instance Cofunctor f => Copair f where
--     { cofst = cofmap fst ; cosnd = cofmap snd }
-- @
class Copair f where
  cofst :: f a -> f (a,b)               -- ^ Pair-like value from first part
  cosnd :: f b -> f (a,b)               -- ^ Pair-like value from second part

instance Copair (Const e) where
  cofst = inConst id
  cosnd = inConst id

-- Standard instance for contravariant functors
instance Arrow (~>) => Copair (Flip (~>) o) where
  { cofst = cofmap fst ; cosnd = cofmap snd }

instance (Functor h, Copair f) => Copair (h :. f) where
  cofst = inO (fmap cofst)
  cosnd = inO (fmap cosnd)

instance (Copair f, Copair g) => Copair (f :*: g) where
  cofst = inProd (cofst *** cofst)
  cosnd = inProd (cosnd *** cosnd)

-- | Pairing of 'Copair' values.  Combines contribution of each.
copair :: (Copair f, Monoid_f f) => PairTy f
fa `copair` fb = cofst fa `mappend_f` cosnd fb

-- Control.Applicative.Endo
-- Handy for "partial values" <http://haskell.org/haskellwiki/Partial>

instance Unpair Endo where  -- Parital == Endo
  pfst = inEndo $ (fst .) . (. (\ a -> (a, undefined)))
  psnd = inEndo $ (snd .) . (. (\ b -> (undefined, b)))

instance Copair Endo where  -- Parital == Endo
  cofst = inEndo first
  cosnd = inEndo second

-- Standard instance for (Monoid_f h, Copair h)
instance Pair Endo where pair = copair



{----------------------------------------------------------
    Misc
----------------------------------------------------------}

-- | Turn a pair of sources into a source of pair-editors.  See
-- <http://conal.net/blog/posts/pairs-sums-and-reactivity/>.
-- 'Functor'\/'Monoid' version.  See also 'pairEditM'.

pairEdit :: (Functor m, Monoid (m ((c,d) -> (c,d)))) =>
            (m c,m d) -> m ((c,d) -> (c,d))
pairEdit (ce,de) =
  fmap (first.const) ce `mappend` fmap (second.const) de


-- | Turn a pair of sources into a source of pair-editors.  See
-- <http://conal.net/blog/posts/pairs-sums-and-reactivity/>.
-- Monad version.  See also 'pairEdit'.
pairEditM :: MonadPlus m => (m c,m d) -> m ((c,d) -> (c,d))
pairEditM (ce,de) =
  liftM (first.const) ce `mplus` liftM (second.const) de