Merge pull request #2 from purescript-contrib/profunctor

Make arrows profunctors

Author: garyb

bower.json

@@ -2,7 +2,8 @@
   "name": "purescript-arrows",
   "homepage": "https://github.com/purescript-contrib/purescript-arrows",
   "authors": [
-    "Phil Freeman <[email protected]>"
+    "Phil Freeman <[email protected]>",
+    "Gary Burgess <[email protected]>"
   ],
   "description": "Type classes for Arrows",
   "keywords": [
@@ -21,6 +22,7 @@
     "package.json"
   ],
   "dependencies": {
-    "purescript-tuples": "*"
+    "purescript-tuples": "~0.2.3",
+    "purescript-profunctor": "~0.0.2"
   }
 }

docs/Module.md

@@ -4,48 +4,65 @@
 
 ### Type Classes
 
-    class (Category a) <= Arrow a where
+
+    class (Category a, Strong a) <= Arrow a where
+
       arr :: forall b c. (b -> c) -> a b c
-      first :: forall b c d. a b c -> a (Tuple b d) (Tuple c d)
+
 
     class ArrowPlus a where
+
       (<+>) :: forall b c. a b c -> a b c -> a b c
 
+
     class ArrowZero a where
+
       azero :: forall b c. a b c
 
 
 ### Type Class Instances
 
+
     instance arrowFunction :: Arrow Prim.Function
 
 
 ### Values
 
+
     (&&&) :: forall a b b' c c'. (Arrow a) => a b c -> a b c' -> a b (Tuple c c')
 
-    (***) :: forall a b b' c c'. (Arrow a) => a b c -> a b' c' -> a (Tuple b b') (Tuple c c')
 
-    second :: forall a b c d. (Arrow a) => a b c -> a (Tuple d b) (Tuple d c)
+    (***) :: forall a b b' c c'. (Arrow a) => a b c -> a b' c' -> a (Tuple b b') (Tuple c c')
 
 
 ## Module Control.Arrow.Kleisli
 
 ### Types
 
+
     newtype Kleisli m a b where
-      Kleisli :: a -> m b -> Kleisli m a b
+      Kleisli :: (a -> m b) -> Kleisli m a b
 
 
 ### Type Class Instances
 
+
     instance arrowKleisli :: (Monad m) => Arrow (Kleisli m)
 
+
     instance categoryKleisli :: (Monad m) => Category (Kleisli m)
 
+
+    instance profunctorKleisli :: (Functor f) => Profunctor (Kleisli f)
+
+
     instance semigroupoidKleisli :: (Monad m) => Semigroupoid (Kleisli m)
 
 
+    instance strongKleisli :: (Monad m) => Strong (Kleisli m)
+
+
 ### Values
 
+
     runKleisli :: forall m a b. Kleisli m a b -> a -> m b

src/Control/Arrow.purs

@@ -1,17 +1,13 @@
 module Control.Arrow where
 
+import Data.Profunctor.Strong
 import Data.Tuple (Tuple(..), swap)
 
-class (Category a) <= Arrow a where
+class (Category a, Strong a) <= Arrow a where
   arr :: forall b c. (b -> c) -> a b c
-  first :: forall b c d. a b c -> a (Tuple b d) (Tuple c d)
 
 instance arrowFunction :: Arrow (->) where
   arr f = f
-  first f (Tuple b d) = Tuple (f b) d
-
-second :: forall a b c d. (Arrow a) => a b c -> a (Tuple d b) (Tuple d c)
-second f = arr swap >>> first f >>> arr swap
 
 infixr 3 ***
 infixr 3 &&&

src/Control/Arrow/Kleisli.purs

@@ -1,6 +1,8 @@
 module Control.Arrow.Kleisli where
 
 import Control.Arrow
+import Data.Profunctor
+import Data.Profunctor.Strong
 import Data.Tuple (Tuple(..), swap)
 
 newtype Kleisli m a b = Kleisli (a -> m b)
@@ -14,6 +16,12 @@ instance semigroupoidKleisli :: (Monad m) => Semigroupoid (Kleisli m) where
 instance categoryKleisli :: (Monad m) => Category (Kleisli m) where
   id = Kleisli return
 
+instance profunctorKleisli :: (Functor f) => Profunctor (Kleisli f) where
+  dimap f g (Kleisli h) = Kleisli ((<$>) g <<< h <<< f)
+
+instance strongKleisli :: (Monad m) => Strong (Kleisli m) where
+  first (Kleisli f) = Kleisli \(Tuple a c) -> f a >>= \b -> return (Tuple b c)
+  second (Kleisli f) = Kleisli \(Tuple c a) -> f a >>= \b -> return (Tuple c b)
+
 instance arrowKleisli :: (Monad m) => Arrow (Kleisli m) where
   arr f = Kleisli (return <<< f)
-  first (Kleisli f) = Kleisli \(Tuple b d) -> f b >>= \c -> return (Tuple c d)