Merge pull request #119 from treeowl/coerce-bind-point

Coerce bind point

.gitignore

@@ -11,3 +11,4 @@ wip
 *.hi
 *~
 *#
+.stack-work/

src/Linear/Affine.hs

@@ -12,7 +12,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 #endif
 {-# LANGUAGE DeriveDataTypeable #-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 708
+#if defined(__GLASGOW_HASKELL__)
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 #endif
@@ -33,6 +33,9 @@ import Control.Monad (liftM)
 import Control.Lens
 import Data.Binary as Binary
 import Data.Bytes.Serial
+#if __GLASGOW_HASKELL__ >= 708
+import Data.Coerce
+#endif
 import Data.Complex (Complex)
 import Data.Data
 import Data.Distributive
@@ -190,17 +193,47 @@ instance Wrapped (Point f a) where
   _Wrapped' = _Point
   {-# INLINE _Wrapped' #-}
 
+#if __GLASGOW_HASKELL__ >= 708
+-- These are stolen from Data.Profunctor.Unsafe
+(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c
+f .# _ = coerce f
+{-# INLINE (.#) #-}
+
+(#.) :: Coercible c b => (b -> c) -> (a -> b) -> a -> c
+(#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b
+{-# INLINE (#.) #-}
+#else
+(.#), (#.) :: (b -> c) -> (a -> b) -> a -> c
+(.#) = (.)
+{-# INLINE (.#) #-}
+(#.) = (.)
+{-# INLINE (#.) #-}
+#endif
+
+unP :: Point f a -> f a
+unP (P x) = x
+{-# INLINE unP #-}
+
+-- We can't use GND to derive 'Bind' because 'join' causes
+-- role troubles. However, GHC 7.8 and above let us use
+-- explicit coercions for (>>-).
 instance Bind f => Bind (Point f) where
-  join (P m) = P $ join $ fmap (\(P m')->m') m
+#if __GLASGOW_HASKELL__ >= 708
+  (>>-) = ((P .) . (. (unP .))) #. (>>-) .# unP
+#else
+  P m >>- f = P $ m >>- unP . f
+#endif
+  join (P m) = P $ m >>- \(P m') -> m'
 
 instance Distributive f => Distributive (Point f) where
   distribute = P . collect (\(P p) -> p)
+  collect = (P .) #. collect .# (unP .)
 
 instance Representable f => Representable (Point f) where
   type Rep (Point f) = Rep f
-  tabulate f = P (tabulate f)
+  tabulate = P #. tabulate
   {-# INLINE tabulate #-}
-  index (P xs) = Rep.index xs
+  index = Rep.index .# unP
   {-# INLINE index #-}
 
 type instance Index (Point f a) = Index (f a)
@@ -238,11 +271,11 @@ instance R4 f => R4 (Point f) where
 
 instance Additive f => Affine (Point f) where
   type Diff (Point f) = f
-  P x .-. P y = x ^-^ y
+  (.-.) = (. unP) #. (^-^) .# unP
   {-# INLINE (.-.) #-}
-  P x .+^ v = P (x ^+^ v)
+  (.+^) = (P .) #. (^+^) .# unP
   {-# INLINE (.+^) #-}
-  P x .-^ v = P (x ^-^ v)
+  (.-^) = (P .) #. (^-^) .# unP
   {-# INLINE (.-^) #-}
 
 -- | Vector spaces have origins.

src/Linear/Vector.hs

@@ -129,26 +129,15 @@ class Functor f => Additive f where
   -- >>> V2 1 2 ^+^ V2 3 4
   -- V2 4 6
   (^+^) :: Num a => f a -> f a -> f a
-#ifdef USE_GHC_GENERICS
-#ifndef HLINT
-  default (^+^) :: Num a => f a -> f a -> f a
   (^+^) = liftU2 (+)
   {-# INLINE (^+^) #-}
-#endif
-#endif
 
   -- | Compute the difference between two vectors
   --
   -- >>> V2 4 5 ^-^ V2 3 1
   -- V2 1 4
   (^-^) :: Num a => f a -> f a -> f a
-#ifdef USE_GHC_GENERICS
-#ifndef HLINT
-  default (^-^) :: Num a => f a -> f a -> f a
   x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
-#endif
 
   -- | Linearly interpolate between two vectors.
   lerp :: Num a => a -> f a -> f a -> f a
@@ -190,12 +179,6 @@ instance Additive ZipList where
   {-# INLINE liftU2 #-}
   liftI2 = liftA2
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive Vector where
   zero = mempty
@@ -212,12 +195,6 @@ instance Additive Vector where
   {-# INLINE liftU2 #-}
   liftI2 = Vector.zipWith
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive Maybe where
   zero = Nothing
@@ -228,12 +205,6 @@ instance Additive Maybe where
   {-# INLINE liftU2 #-}
   liftI2 = liftA2
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive [] where
   zero = []
@@ -245,12 +216,6 @@ instance Additive [] where
   {-# INLINE liftU2 #-}
   liftI2 = Prelude.zipWith
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive IntMap where
   zero = IntMap.empty
@@ -259,12 +224,6 @@ instance Additive IntMap where
   {-# INLINE liftU2 #-}
   liftI2 = IntMap.intersectionWith
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Ord k => Additive (Map k) where
   zero = Map.empty
@@ -273,12 +232,6 @@ instance Ord k => Additive (Map k) where
   {-# INLINE liftU2 #-}
   liftI2 = Map.intersectionWith
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance (Eq k, Hashable k) => Additive (HashMap k) where
   zero = HashMap.empty
@@ -287,12 +240,6 @@ instance (Eq k, Hashable k) => Additive (HashMap k) where
   {-# INLINE liftU2 #-}
   liftI2 = HashMap.intersectionWith
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive ((->) b) where
   zero   = const 0
@@ -301,12 +248,6 @@ instance Additive ((->) b) where
   {-# INLINE liftU2 #-}
   liftI2 = liftA2
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive Complex where
   zero = 0 :+ 0
@@ -315,12 +256,6 @@ instance Additive Complex where
   {-# INLINE liftU2 #-}
   liftI2 f (a :+ b) (c :+ d) = f a c :+ f b d
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 instance Additive Identity where
   zero = Identity 0
@@ -329,12 +264,6 @@ instance Additive Identity where
   {-# INLINE liftU2 #-}
   liftI2 = liftA2
   {-# INLINE liftI2 #-}
-#ifndef USE_GHC_GENERICS
-  (^+^) = liftU2 (+)
-  {-# INLINE (^+^) #-}
-  x ^-^ y = x ^+^ negated y
-  {-# INLINE (^-^) #-}
-#endif
 
 -- | Compute the negation of a vector
 --