summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorConalElliott <>2008-10-29 19:18:13 (GMT)
committerLuite Stegeman <luite@luite.com>2008-10-29 19:18:13 (GMT)
commit3293bac1e9b50bf7a9fc47044d9d2322be550979 (patch)
tree849a21acc07f5940bf90e9cfa3eb577ba8b932d1
parenta01eb2a745226f35dec78c642c9b68bedd16ef86 (diff)
version 0.5.10.5.1
-rwxr-xr-xCHANGES4
-rwxr-xr-xTypeCompose.cabal2
-rwxr-xr-xsrc/Control/Compose.hs47
-rwxr-xr-xsrc/Data/Bijection.hs16
4 files changed, 62 insertions, 7 deletions
diff --git a/CHANGES b/CHANGES
index 267d344..191a8fe 100755
--- a/CHANGES
+++ b/CHANGES
@@ -1,5 +1,9 @@
% TypeCompose changes
+== Version 0.5.1 ==
+
+* Tweaked to work with ghc before and after 6.9
+
== Version 0.5 ==
* Backed out DistribM. Now that I've read "Composing Monads", I know
diff --git a/TypeCompose.cabal b/TypeCompose.cabal
index 6f31d69..f492fc4 100755
--- a/TypeCompose.cabal
+++ b/TypeCompose.cabal
@@ -1,5 +1,5 @@
Name: TypeCompose
-Version: 0.5
+Version: 0.5.1
Synopsis: Type composition classes & instances
Category: Composition, Control
Description:
diff --git a/src/Control/Compose.hs b/src/Control/Compose.hs
index a483e9a..8d93892 100755
--- a/src/Control/Compose.hs
+++ b/src/Control/Compose.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses
, FlexibleContexts, UndecidableInstances, TypeSynonymInstances
, TypeOperators, GeneralizedNewtypeDeriving, StandaloneDeriving
+ , CPP
#-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}
@@ -61,7 +62,16 @@ module Control.Compose
import Control.Applicative
-- import Control.Monad (liftM,join)
-import Control.Arrow hiding (pure)
+#if __GLASGOW_HASKELL__ >= 609
+import Control.Category
+import Prelude hiding ((.), id)
+#endif
+
+import Control.Arrow
+#if __GLASGOW_HASKELL__ < 610
+ hiding (pure)
+#endif
+
import Data.Monoid
-- import Test.QuickCheck -- for Endo
@@ -260,9 +270,18 @@ joinMM = O . liftM join . join . liftM distribM . unO . liftM unO
-- "StaticArrow" in [1].
newtype OO f (~>) a b = OO { unOO :: f (a ~> b) }
+
+#if __GLASGOW_HASKELL__ >= 609
+instance (Applicative f, Category (~>)) => Category (OO f (~>)) where
+ id = OO (pure id)
+ OO g . OO h = OO (liftA2 (.) g h)
+#endif
+
instance (Applicative f, Arrow (~>)) => Arrow (OO f (~>)) where
- arr = OO . pure . arr
+#if __GLASGOW_HASKELL__ < 609
OO g >>> OO h = OO (liftA2 (>>>) g h)
+#endif
+ arr = OO . pure . arr
first (OO g) = OO (liftA first g)
-- For instance, /\ a b. f (a -> m b) =~ OO f Kleisli m
@@ -347,9 +366,19 @@ class FunAble h where
f ***% g = firstFun f >>> secondFun g
f &&&% g = arrFun (\b -> (b,b)) >>> f ***% g
+
+#if __GLASGOW_HASKELL__ >= 609
+instance FunAble h => Category (FunA h) where
+ id = FunA (arrFun id)
+ (.) = inFunA2 (.)
+#endif
+
+
instance FunAble h => Arrow (FunA h) where
arr p = FunA (arrFun p)
+#if __GLASGOW_HASKELL__ < 609
(>>>) = inFunA2 (>>>)
+#endif
first = inFunA firstFun
second = inFunA secondFun
(***) = inFunA2 (***%)
@@ -595,9 +624,19 @@ inProdd2 :: ((f a b, g a b) -> (f' a' b', g' a' b') -> (f'' a'' b'', g'' a'' b''
-> ((f ::*:: g) a b -> (f' ::*:: g') a' b' -> (f'' ::*:: g'') a'' b'')
inProdd2 h (Prodd p) = inProdd (h p)
+
+#if __GLASGOW_HASKELL__ >= 609
+instance (Category f, Category f') => Category (f ::*:: f') where
+ id = Prodd (id,id)
+ (.) = inProdd2 ((.) ***# (.))
+#endif
+
+
instance (Arrow f, Arrow f') => Arrow (f ::*:: f') where
- arr = Prodd . (arr &&& arr )
- (>>>) = inProdd2 ((>>>) ***# (>>>) )
+ arr = Prodd . (arr &&& arr)
+#if __GLASGOW_HASKELL__ < 609
+ (>>>) = inProdd2 ((>>>) ***# (>>>))
+#endif
first = inProdd (first *** first )
second = inProdd (second *** second)
(***) = inProdd2 ((***) ***# (***) )
diff --git a/src/Data/Bijection.hs b/src/Data/Bijection.hs
index a616a15..79484b9 100755
--- a/src/Data/Bijection.hs
+++ b/src/Data/Bijection.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeOperators, CPP #-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts #-}
@@ -25,6 +25,10 @@ module Data.Bijection
, inBi
) where
+#if __GLASGOW_HASKELL__ >= 609
+import Control.Category
+import Prelude hiding ((.), id)
+#endif
import Control.Arrow
@@ -47,9 +51,17 @@ idb = Bi idA idA where idA = arr id
inverse :: Bijection (~>) a b -> Bijection (~>) b a
inverse (Bi ab ba) = Bi ba ab
+#if __GLASGOW_HASKELL__ >= 609
+instance Category (~>) => Category (Bijection (~>)) where
+ id = Bi id id
+ Bi bc cb . Bi ab ba = Bi (bc . ab) (ba . cb)
+#endif
+
instance Arrow (~>) => Arrow (Bijection (~>)) where
- arr = error "No arr for (:<->:)."
+#if __GLASGOW_HASKELL__ < 609
Bi ab ba >>> Bi bc cb = Bi (ab >>> bc) (cb >>> ba)
+#endif
+ arr = error "No arr for (:<->:)."
first (Bi ab ba) = Bi (first ab) (first ba)
second (Bi ab ba) = Bi (second ab) (second ba)
Bi ab ba *** Bi cd dc = Bi (ab *** cd) (ba *** dc)