summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorConalElliott <>2012-11-13 19:26:23 (GMT)
committerhdiff <hdiff@luite.com>2012-11-13 19:26:23 (GMT)
commitc8f2dbe5f6c7919bd7f740a92dc70350026364c0 (patch)
tree0f8af27677a458d9b1be00ae455de26e0d6c0657
parente9bb45df70a7b9517252baec51e86c68e9b0673a (diff)
version 0.9.70.9.7
-rw-r--r--TypeCompose.cabal3
-rw-r--r--src/Control/Compose.hs68
-rw-r--r--src/Data/Bijection.hs16
-rw-r--r--src/Data/Lambda.hs8
-rw-r--r--src/Data/Pair.hs10
-rw-r--r--src/Data/Zip.hs10
6 files changed, 59 insertions, 56 deletions
diff --git a/TypeCompose.cabal b/TypeCompose.cabal
index 3c72462..042c958 100644
--- a/TypeCompose.cabal
+++ b/TypeCompose.cabal
@@ -1,5 +1,5 @@
Name: TypeCompose
-Version: 0.9.6
+Version: 0.9.7
Synopsis: Type composition classes & instances
Category: Composition, Control
Cabal-Version: >= 1.6
@@ -12,6 +12,7 @@ Description:
Copyright 2007-2012 by Conal Elliott; BSD3 license.
Author: Conal Elliott
Maintainer: conal@conal.net
+Homepage: https://github.com/conal/TypeCompose
Copyright: (c) 2007-2012 by Conal Elliott
License: BSD3
License-File: COPYING
diff --git a/src/Control/Compose.hs b/src/Control/Compose.hs
index 0f5834d..fcfc5ba 100644
--- a/src/Control/Compose.hs
+++ b/src/Control/Compose.hs
@@ -113,29 +113,29 @@ type Binop a = a -> a -> a
-- | Add pre-processing
-- argument :: (a' -> a) -> ((a -> b) -> (a' -> b))
-argument :: Category (-->) => (a' --> a) -> ((a --> b) -> (a' --> b))
+argument :: Category cat => (a' `cat` a) -> ((a `cat` b) -> (a' `cat` b))
argument = flip (.)
-- | Add post-processing
-result :: Category (-->) => (b --> b') -> ((a --> b) -> (a --> b'))
+result :: Category cat => (b `cat` b') -> ((a `cat` b) -> (a `cat` b'))
result = (.)
infixr 1 ~>, ~>*
infixl 1 <~, *<~
-- | Add pre- and post processing
-(~>) :: Category (-->) =>
- (a' --> a) -> (b --> b') -> ((a --> b) -> (a' --> b'))
+(~>) :: Category cat =>
+ (a' `cat` a) -> (b `cat` b') -> ((a `cat` b) -> (a' `cat` b'))
-- (f ~> h) g = h . g . f
f ~> h = result h . argument f
-(<~) :: Category (-->) =>
- (b --> b') -> (a' --> a) -> ((a --> b) -> (a' --> b'))
+(<~) :: Category cat =>
+ (b `cat` b') -> (a' `cat` a) -> ((a `cat` b) -> (a' `cat` b'))
(<~) = flip (~>)
-- If I add argument back to DeepArrow, we can get a different generalization:
--
--- (~>) :: DeepArrow (-->) => (a' --> a) -> (b --> b') -> ((a -> b) --> (a' -> b'))
+-- (~>) :: DeepArrow cat => (a' `cat` a) -> (b `cat` b') -> ((a -> b) `cat` (a' -> b'))
-- | Like '(~>)' but specialized to functors and functions.
(~>*) :: (Functor p, Functor q) =>
@@ -404,16 +404,16 @@ joinComposeT = O . joinMMT . unO . fmap unO
-- | Composition of type constructors: unary with binary. Called
-- "StaticArrow" in [1].
-newtype OO f (~>) a b = OO { unOO :: f (a ~> b) }
+newtype OO f j a b = OO { unOO :: f (a `j` b) }
#if __GLASGOW_HASKELL__ >= 609
-instance (Applicative f, Category (~>)) => Category (OO f (~>)) where
+instance (Applicative f, Category cat) => Category (OO f cat) where
id = OO (pure id)
OO g . OO h = OO (liftA2 (.) g h)
#endif
-instance (Applicative f, Arrow (~>)) => Arrow (OO f (~>)) where
+instance (Applicative f, Arrow arr) => Arrow (OO f arr) where
#if __GLASGOW_HASKELL__ < 609
OO g >>> OO h = OO (liftA2 (>>>) g h)
#endif
@@ -545,31 +545,31 @@ instance Monoid_f [] where { mempty_f = mempty ; mappend_f = mappend }
----------------------------------------------------------}
-- | Flip type arguments
-newtype Flip (~>) b a = Flip { unFlip :: a ~> b }
+newtype Flip j b a = Flip { unFlip :: a `j` b }
-- | @newtype@ bijection
-biFlip :: (a ~> b) :<->: Flip (~>) b a
+biFlip :: (a `j` b) :<->: Flip j b a
biFlip = Bi Flip unFlip
-- Apply unary function inside of a 'Flip' representation.
-inFlip :: ((a~>b) -> (a' ~~> b')) -> (Flip (~>) b a -> Flip (~~>) b' a')
+inFlip :: ((a `j` b) -> (a' `k` b')) -> (Flip j b a -> Flip k b' a')
inFlip = unFlip ~> Flip
-- Apply binary function inside of a 'Flip' representation.
-inFlip2 :: ((a~>b) -> (a' ~~> b') -> (a'' ~~~> b''))
- -> (Flip (~>) b a -> Flip (~~>) b' a' -> Flip (~~~>) b'' a'')
+inFlip2 :: ((a `j` b) -> (a' `k` b') -> (a'' `l` b''))
+ -> (Flip j b a -> Flip k b' a' -> Flip l b'' a'')
inFlip2 f (Flip ar) = inFlip (f ar)
-- Apply ternary function inside of a 'Flip' representation.
-inFlip3 :: ((a~>b) -> (a' ~~> b') -> (a'' ~~~> b'') -> (a''' ~~~~> b'''))
- -> (Flip (~>) b a -> Flip (~~>) b' a' -> Flip (~~~>) b'' a'' -> Flip (~~~~>) b''' a''')
+inFlip3 :: ((a `j` b) -> (a' `k` b') -> (a'' `l` b'') -> (a''' `m` b'''))
+ -> (Flip j b a -> Flip k b' a' -> Flip l b'' a'' -> Flip m b''' a''')
inFlip3 f (Flip ar) = inFlip2 (f ar)
-instance Arrow (~>) => ContraFunctor (Flip (~>) b) where
+instance Arrow arr => ContraFunctor (Flip arr b) where
contraFmap h (Flip f) = Flip (arr h >>> f)
-- Useful for (~>) = (->). Maybe others.
-instance (Applicative ((~>) a), Monoid o) => Monoid (Flip (~>) o a) where
+instance (Applicative (j a), Monoid o) => Monoid (Flip j o a) where
mempty = Flip (pure mempty)
mappend = inFlip2 (liftA2 mappend)
@@ -813,42 +813,44 @@ instance (Arrow f, Arrow f') => Arrow (f ::*:: f') where
-- | Arrow-like type between type constructors (doesn't enforce @Arrow
-- (~>)@ here).
-newtype Arrw (~>) f g a = Arrw { unArrw :: f a ~> g a } -- deriving Monoid
+newtype Arrw j f g a = Arrw { unArrw :: f a `j` g a } -- deriving Monoid
-- For ghc-6.6, use the "deriving" above, but for 6.8 use the "deriving" below.
-deriving instance Monoid (f a ~> g a) => Monoid (Arrw (~>) f g a)
+deriving instance Monoid (f a `j` g a) => Monoid (Arrw j f g a)
-- Replace with generalized bijection?
--- toArrw :: Arrow (~>) => (f a ~> b) -> (c ~> g a) -> ((b ~> c) -> Arrw (~>) f g a)
+-- toArrw :: Arrow j => (f a ~> b) -> (c ~> g a) -> ((b ~> c) -> Arrw j f g a)
-- toArrw fromF toG h = Arrw (fromF >>> h >>> toG)
--- fromArrw :: Arrow (~>) => (b ~> f a) -> (g a ~> c) -> (Arrw (~>) f g a -> (b ~> c))
+-- fromArrw :: Arrow j => (b ~> f a) -> (g a ~> c) -> (Arrw j f g a -> (b ~> c))
-- fromArrw toF fromG (Arrw h') = toF >>> h' >>> fromG
-- | Apply unary function inside of @Arrw@ representation.
-inArrw :: ((f a ~> g a) -> (f' a' ~> g' a'))
- -> ((Arrw (~>) f g) a -> (Arrw (~>) f' g') a')
+inArrw :: ((f a `j` g a) -> (f' a' `j` g' a'))
+ -> ((Arrw j f g) a -> (Arrw j f' g') a')
inArrw = unArrw ~> Arrw
--- | Apply binary function inside of @Arrw (~>) f g@ representation.
-inArrw2 :: ((f a ~> g a) -> (f' a' ~> g' a') -> (f'' a'' ~> g'' a''))
- -> (Arrw (~>) f g a -> Arrw (~>) f' g' a' -> Arrw (~>) f'' g'' a'')
+-- | Apply binary function inside of @Arrw j f g@ representation.
+inArrw2 :: ((f a `j` g a) -> (f' a' `j` g' a') -> (f'' a'' `j` g'' a''))
+ -> (Arrw j f g a -> Arrw j f' g' a' -> Arrw j f'' g'' a'')
inArrw2 h (Arrw p) = inArrw (h p)
--- | Apply ternary function inside of @Arrw (~>) f g@ representation.
-inArrw3 :: ((f a ~> g a) -> (f' a' ~> g' a') -> (f'' a'' ~> g'' a'') -> (f''' a''' ~> g''' a'''))
- -> ((Arrw (~>) f g) a -> (Arrw (~>) f' g') a' -> (Arrw (~>) f'' g'') a'' -> (Arrw (~>) f''' g''') a''')
+-- | Apply ternary function inside of @Arrw j f g@ representation.
+inArrw3 ::
+ ((f a `j` g a) -> (f' a' `j` g' a') ->
+ (f'' a'' `j` g'' a'') -> (f''' a''' `j` g''' a'''))
+ -> ((Arrw j f g) a -> (Arrw j f' g') a' -> (Arrw j f'' g'') a'' -> (Arrw j f''' g''') a''')
inArrw3 h (Arrw p) = inArrw2 (h p)
-- Functor & ContraFunctor instances. Beware use of 'arr', which is not
-- available for some of my favorite arrows.
-instance (Arrow (~>), ContraFunctor f, Functor g) => Functor (Arrw (~>) f g) where
+instance (Arrow j, ContraFunctor f, Functor g) => Functor (Arrw j f g) where
fmap h = inArrw $ \ fga -> arr (contraFmap h) >>> fga >>> arr (fmap h)
-instance (Arrow (~>), Functor f, ContraFunctor g) => ContraFunctor (Arrw (~>) f g) where
+instance (Arrow j, Functor f, ContraFunctor g) => ContraFunctor (Arrw j f g) where
contraFmap h = inArrw $ \ fga -> arr (fmap h) >>> fga >>> arr (contraFmap h)
-- Restated,
diff --git a/src/Data/Bijection.hs b/src/Data/Bijection.hs
index ab4ca69..58ed63a 100644
--- a/src/Data/Bijection.hs
+++ b/src/Data/Bijection.hs
@@ -33,7 +33,7 @@ infix 8 :<->:
infixr 2 --->
-- | A type of bijective arrows
-data Bijection (~>) a b = Bi { biTo :: a ~> b, biFrom :: b ~> a }
+data Bijection j a b = Bi { biTo :: a `j` b, biFrom :: b `j` a }
-- | Bijective functions
type a :<->: b = Bijection (->) a b
@@ -41,20 +41,20 @@ type a :<->: b = Bijection (->) a b
-- | Bijective identity arrow. Warning: uses 'arr' on @(~>)@. If you
-- have no 'arr', but you have a @DeepArrow@, you can instead use @Bi idA
-- idA@.
-idb :: Arrow (~>) => Bijection (~>) a a
+idb :: Arrow j => Bijection j a a
idb = Bi idA idA where idA = arr id
-- | Inverse bijection
-inverse :: Bijection (~>) a b -> Bijection (~>) b a
+inverse :: Bijection j a b -> Bijection j b a
inverse (Bi ab ba) = Bi ba ab
#if __GLASGOW_HASKELL__ >= 609
-instance Category (~>) => Category (Bijection (~>)) where
+instance Category j => Category (Bijection j) where
id = Bi id id
Bi bc cb . Bi ab ba = Bi (bc . ab) (ba . cb)
#endif
-instance Arrow (~>) => Arrow (Bijection (~>)) where
+instance Arrow j => Arrow (Bijection j) where
#if __GLASGOW_HASKELL__ < 609
Bi ab ba >>> Bi bc cb = Bi (ab >>> bc) (cb >>> ba)
#endif
@@ -75,8 +75,8 @@ bimap :: Functor f => (a :<->: b) -> (f a :<->: f b)
bimap (Bi ab ba) = Bi (fmap ab) (fmap ba)
-- | Bijections on arrows.
-(--->) :: Arrow (~>) => Bijection (~>) a b -> Bijection (~>) c d
- -> (a ~> c) :<->: (b ~> d)
+(--->) :: Arrow j => Bijection j a b -> Bijection j c d
+ -> (a `j` c) :<->: (b `j` d)
Bi ab ba ---> Bi cd dc = Bi (\ ac -> ba>>>ac>>>cd) (\ bd -> ab>>>bd>>>dc)
-- TODO: Rewrite (--->) via (~>). Currently would cause a module cycle
@@ -85,5 +85,5 @@ Bi ab ba ---> Bi cd dc = Bi (\ ac -> ba>>>ac>>>cd) (\ bd -> ab>>>bd>>>dc)
-- | Apply a function in an alternative (monomorphic) representation.
-inBi :: Arrow (~>) => Bijection (~>) a b -> (a ~> a) -> (b ~> b)
+inBi :: Arrow j => Bijection j a b -> (a `j` a) -> (b `j` b)
inBi (Bi to from) aa = from >>> aa >>> to
diff --git a/src/Data/Lambda.hs b/src/Data/Lambda.hs
index 661c599..8d258e0 100644
--- a/src/Data/Lambda.hs
+++ b/src/Data/Lambda.hs
@@ -93,13 +93,13 @@ instance (Lambda src snk, Lambda dom' ran')
-- | 'lambda' with 'Arrw'. /Warning/: definition uses 'arr', so only
-- use if your arrow has a working 'arr'.
-arLambda :: (Arrow (~>), Unlambda f f', Lambda g g')
- => LambdaTy (Arrw (~>) f g) (Arrw (~>) f' g')
+arLambda :: (Arrow j, Unlambda f f', Lambda g g')
+ => LambdaTy (Arrw j f g) (Arrw j f' g')
arLambda = inArrw2 $ \ fga fgb ->
arr unlambda >>> fga***fgb >>> arr (uncurry lambda)
-instance (Arrow (~>), Unlambda f f', Lambda g g')
- => Lambda (Arrw (~>) f g) (Arrw (~>) f' g')
+instance (Arrow j, Unlambda f f', Lambda g g')
+ => Lambda (Arrw j f g) (Arrw j f' g')
where lambda = arLambda
diff --git a/src/Data/Pair.hs b/src/Data/Pair.hs
index b7663f2..a463778 100644
--- a/src/Data/Pair.hs
+++ b/src/Data/Pair.hs
@@ -95,8 +95,8 @@ 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
+instance (Arrow j, Monoid_f (Flip j o)) =>
+ Pair (Flip j o) where pair = copair
-- | Handy for 'Pair' instances
apPair :: (Applicative h, Pair f) => PairTy (h :. f)
@@ -108,12 +108,12 @@ 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 :: (Arrow j, Unpair f, Pair g) => PairTy (Arrw j 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)
+instance (Arrow j, Unpair f, Pair g) => Pair (Arrw j f g)
where pair = arPair
instance (Pair f, Pair g) => Pair (f :*: g) where
@@ -175,7 +175,7 @@ instance Copair (Const e) where
cosnds = inConst id
-- Standard instance for contravariant functors
-instance Arrow (~>) => Copair (Flip (~>) o) where
+instance Arrow j => Copair (Flip j o) where
{ cofsts = contraFmap fst ; cosnds = contraFmap snd }
instance (Functor h, Copair f) => Copair (h :. f) where
diff --git a/src/Data/Zip.hs b/src/Data/Zip.hs
index ad77b6c..3176019 100644
--- a/src/Data/Zip.hs
+++ b/src/Data/Zip.hs
@@ -126,8 +126,8 @@ instance Zip Id where Id a `zip` 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)) =>
- Zip (Flip (~>) o) where zip = cozip
+instance (Arrow j, Monoid_f (Flip j o)) =>
+ Zip (Flip j o) where zip = cozip
-- | Handy for 'Zip' instances
apZip :: (Applicative h, Zip f) => ZipTy (h :. f)
@@ -139,12 +139,12 @@ ppZip = inO2 $ \ gfa gfb -> uncurry zip <$> (gfa `zip` gfb)
-- | Ziping of 'Arrw' values. /Warning/: definition uses 'arr', so only
-- use if your arrow has a working 'arr'.
-arZip :: (Arrow (~>), Unzip f, Zip g) => ZipTy (Arrw (~>) f g)
+arZip :: (Arrow j, Unzip f, Zip g) => ZipTy (Arrw j f g)
arZip = inArrw2 $ \ fga fgb ->
arr unzip >>> fga***fgb >>> arr (uncurry zip)
-- Standard instance
-instance (Arrow (~>), Unzip f, Zip g) => Zip (Arrw (~>) f g)
+instance (Arrow j, Unzip f, Zip g) => Zip (Arrw j f g)
where zip = arZip
instance (Zip f, Zip g) => Zip (f :*: g) where
@@ -206,7 +206,7 @@ instance Cozip (Const e) where
cosnds = inConst id
-- Standard instance for contravariant functors
-instance Arrow (~>) => Cozip (Flip (~>) o) where
+instance Arrow j => Cozip (Flip j o) where
{ cofsts = contraFmap fst ; cosnds = contraFmap snd }
instance (Functor h, Cozip f) => Cozip (h :. f) where