summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorConalElliott <>2009-10-05 00:10:54 (GMT)
committerLuite Stegeman <luite@luite.com>2009-10-05 00:10:54 (GMT)
commit1b76acf940f26cf330c4c4e04060bd113b302315 (patch)
treefe7456554e6454634010a307cadff6b6d32cadf1
parent4d41af80d746d09560c7f1ddb17b7412a3131ad5 (diff)
version 0.6.70.6.7
-rwxr-xr-xTypeCompose.cabal2
-rw-r--r--src/Data/Pair.hs228
2 files changed, 229 insertions, 1 deletions
diff --git a/TypeCompose.cabal b/TypeCompose.cabal
index 8ef3e24..4dc0dae 100755
--- a/TypeCompose.cabal
+++ b/TypeCompose.cabal
@@ -1,5 +1,5 @@
Name: TypeCompose
-Version: 0.6.6
+Version: 0.6.7
Synopsis: Type composition classes & instances
Category: Composition, Control
Description:
diff --git a/src/Data/Pair.hs b/src/Data/Pair.hs
new file mode 100644
index 0000000..8e23a93
--- /dev/null
+++ b/src/Data/Pair.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE Rank2Types, TypeOperators, UndecidableInstances, CPP #-}
+{-# OPTIONS_GHC -Wall #-}
+#if __GLASGOW_HASKELL__ < 610
+{-# OPTIONS_GHC -frewrite-rules #-}
+#else
+{-# OPTIONS_GHC -fenable-rewrite-rules #-}
+#endif
+
+----------------------------------------------------------------------
+-- |
+-- Module : Data.Pair
+-- Copyright : (c) Conal Elliott 2007
+-- License : BSD3
+--
+-- Maintainer : conal@conal.net
+-- Stability : experimental
+-- Portability : GHC
+--
+-- Pair-related type constructor classes.
+--
+-- This module is similar to @Control.Functor.Pair@ in the
+-- @category-extras@ package, but it does not require a 'Functor'
+-- superclass.
+--
+-- Temporarily, there is also Data.Zip, which contains the same
+-- functionality with different naming. I'm unsure which I prefer.
+----------------------------------------------------------------------
+
+module Data.Pair
+ (
+ -- * Pairpings
+ 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
+
+
+{----------------------------------------------------------
+ Pairpings
+----------------------------------------------------------}
+
+-- | Type of 'pair' method
+type PairTy f = forall a b. f a -> f b -> f (a,b)
+
+-- | Type constructor class for 'pair'-like things.
+-- 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':
+--
+-- > (<*>) = pairWith ($)
+--
+-- Minimum definitions for instances.
+
+class Pair f where
+ pair :: PairTy f -- ^ Generalized 'pair'
+
+-- Standard instances (Applicative f)
+instance Pair [] where pair = zip
+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 -> 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 'unpair'.
+type UnpairTy f = forall a b. f (a,b) -> (f a, f b)
+
+-- | Unpairpable. Minimal instance definition: either (a) 'unpair' /or/ (b)
+-- both of 'fsts' /and/ 'snds'. A standard template to substitute any
+-- 'Functor' @f.@ But watch out for effects!
+--
+-- > instance Functor f => Unpair f where {fsts = fmap fst; snds = fmap snd}
+
+class Unpair f where
+ unpair :: UnpairTy f -- ^ generalized unpair
+ fsts :: f (a,b) -> f a -- ^ First part of pair-like value
+ snds :: f (a,b) -> f b -- ^ Second part of pair-like value
+
+ unpair = fsts &&& snds
+ fsts = fst.unpair
+ snds = snd.unpair
+
+instance Unpair [] where
+ unpair = unzip -- single pass. don't use default
+ fsts = fmap fst
+ snds = fmap snd
+
+-- Some standard instances for functors
+instance Unpair ((->) a) where { fsts = fmap fst; snds = fmap snd }
+instance Unpair ((,) a) where { fsts = fmap fst; snds = fmap snd }
+instance Unpair (Const a) where { fsts = fmap fst; snds = fmap snd }
+instance Unpair Id where { fsts = fmap fst; snds = 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
+-- > { cofsts = cofmap fst ; cosnds = cofmap snd }
+
+class Copair f where
+ cofsts :: f a -> f (a,b) -- ^ Pair-like value from first part
+ cosnds :: f b -> f (a,b) -- ^ Pair-like value from second part
+
+instance Copair (Const e) where
+ cofsts = inConst id
+ cosnds = inConst id
+
+-- Standard instance for contravariant functors
+instance Arrow (~>) => Copair (Flip (~>) o) where
+ { cofsts = cofmap fst ; cosnds = cofmap snd }
+
+instance (Functor h, Copair f) => Copair (h :. f) where
+ cofsts = inO (fmap cofsts)
+ cosnds = inO (fmap cosnds)
+
+instance (Copair f, Copair g) => Copair (f :*: g) where
+ cofsts = inProd (cofsts *** cofsts)
+ cosnds = inProd (cosnds *** cosnds)
+
+-- | Pairing of 'Copair' values. Combines contribution of each.
+copair :: (Copair f, Monoid_f f) => PairTy f
+fa `copair` fb = cofsts fa `mappend_f` cosnds fb
+
+-- Control.Applicative.Endo
+-- Handy for "partial values" <http://haskell.org/haskellwiki/Partial>
+
+instance Unpair Endo where -- Parital == Endo
+ fsts = inEndo $ (fst .) . (. (\ a -> (a, undefined)))
+ snds = inEndo $ (snd .) . (. (\ b -> (undefined, b)))
+
+instance Copair Endo where -- Parital == Endo
+ cofsts = inEndo first
+ cosnds = 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