Add Costar, more Star instances (#16)

Author: garyb

bower.json

@@ -22,6 +22,7 @@
     "package.json"
   ],
   "dependencies": {
+    "purescript-distributive": "^1.0.0-rc.1",
     "purescript-either": "^1.0.0-rc.1",
     "purescript-tuples": "^1.0.0-rc.1"
   }

src/Data/Profunctor/Costar.purs

@@ -0,0 +1,76 @@
+module Data.Profunctor.Costar where
+
+import Prelude
+
+import Control.Comonad (class Comonad, extract)
+import Control.Extend (class Extend, (=<=))
+
+import Data.Distributive (class Distributive, distribute)
+import Data.Either (Either(..), either)
+import Data.Functor.Invariant (class Invariant, imapF)
+import Data.Profunctor (class Profunctor)
+import Data.Profunctor.Closed (class Closed)
+import Data.Profunctor.Cochoice (class Cochoice)
+import Data.Profunctor.Costrong (class Costrong)
+import Data.Profunctor.Strong (class Strong)
+import Data.Tuple (Tuple(..), fst, snd)
+
+-- | `Costar` turns a `Functor` into a `Profunctor` "backwards".
+-- |
+-- | `Costar f` is also the co-Kleisli category for `f`.
+newtype Costar f b a = Costar (f b -> a)
+
+-- | Unwrap a value of type `Costar f a b`.
+unCostar :: forall f a b. Costar f b a -> f b -> a
+unCostar (Costar f) = f
+
+instance semigroupoidCostar :: Extend f => Semigroupoid (Costar f) where
+  compose (Costar f) (Costar g) = Costar (f =<= g)
+
+instance categoryCostar :: Comonad f => Category (Costar f) where
+  id = Costar extract
+
+instance functorCostar :: Functor (Costar f a) where
+  map f (Costar g) = Costar (f <<< g)
+
+instance invariantCostar :: Invariant (Costar f a) where
+  imap = imapF
+
+instance applyCostar :: Apply (Costar f a) where
+  apply (Costar f) (Costar g) = Costar \a -> f a (g a)
+
+instance applicativeCostar :: Applicative (Costar f a) where
+  pure a = Costar \_ -> a
+
+instance bindCostar :: Bind (Costar f a) where
+  bind (Costar m) f = Costar \x -> unCostar (f (m x)) x
+
+instance monadCostar :: Monad (Costar f a)
+
+instance distributiveCostar :: Distributive f => Distributive (Costar f a) where
+  distribute f = Costar \g -> map ((_ $ g) <<< unCostar) f
+  collect f = distribute <<< map f
+
+instance profunctorCostar :: Functor f => Profunctor (Costar f) where
+  dimap f g (Costar h) = Costar (map f >>> h >>> g)
+
+instance strongCostar :: Comonad f => Strong (Costar f) where
+  first (Costar f) = Costar \x -> Tuple (f (map fst x)) (snd (extract x))
+  second (Costar f) = Costar \x -> Tuple (fst (extract x)) (f (map snd x))
+
+instance costrongCostar :: Functor f => Costrong (Costar f) where
+  unfirst (Costar f) = Costar \fb ->
+    let bd = f ((\a -> Tuple a (snd bd)) <$> fb) in fst bd
+  unsecond (Costar f) = Costar \fb ->
+    let db = f ((\a -> Tuple (fst db) a) <$> fb) in snd db
+
+instance cochoiceCostar :: Applicative f => Cochoice (Costar f) where
+  unleft (Costar f) =
+    let g = either id (\r -> g (pure (Right r))) <<< f
+    in Costar (g <<< map Left)
+  unright (Costar f) =
+    let g = either (\l -> g (pure (Left l))) id <<< f
+    in Costar (g <<< map Right)
+
+instance closedCostar :: Functor f => Closed (Costar f) where
+  closed (Costar f) = Costar \g x -> f (map (_ $ x) g)

src/Data/Profunctor/Star.purs

@@ -2,19 +2,69 @@ module Data.Profunctor.Star where
 
 import Prelude
 
-import Data.Tuple (Tuple(..))
+import Control.Alt (class Alt, (<|>))
+import Control.Alternative (class Alternative)
+import Control.MonadPlus (class MonadPlus)
+import Control.MonadZero (class MonadZero)
+import Control.Plus (class Plus, empty)
+
+import Data.Distributive (class Distributive, distribute, collect)
 import Data.Either (Either(..), either)
+import Data.Functor.Invariant (class Invariant, imap)
 import Data.Profunctor (class Profunctor)
-import Data.Profunctor.Strong (class Strong)
 import Data.Profunctor.Choice (class Choice)
+import Data.Profunctor.Closed (class Closed)
+import Data.Profunctor.Strong (class Strong)
+import Data.Tuple (Tuple(..))
 
 -- | `Star` turns a `Functor` into a `Profunctor`.
+-- |
+-- | `Star f` is also the Kleisli category for `f`
 newtype Star f a b = Star (a -> f b)
 
 -- | Unwrap a value of type `Star f a b`.
 unStar :: forall f a b. Star f a b -> a -> f b
 unStar (Star f) = f
 
+instance semigroupoidStar :: Bind f => Semigroupoid (Star f) where
+  compose (Star f) (Star g) = Star \x -> g x >>= f
+
+instance categoryStar :: Monad f => Category (Star f) where
+  id = Star pure
+
+instance functorStar :: Functor f => Functor (Star f a) where
+  map f (Star g) = Star (map f <<< g)
+
+instance invariantStar :: Invariant f => Invariant (Star f a) where
+  imap f g (Star h) = Star (imap f g <<< h)
+
+instance applyStar :: Apply f => Apply (Star f a) where
+  apply (Star f) (Star g) = Star \a -> f a <*> g a
+
+instance applicativeStar :: Applicative f => Applicative (Star f a) where
+  pure a = Star \_ -> pure a
+
+instance bindStar :: Bind f => Bind (Star f a) where
+  bind (Star m) f = Star \x -> m x >>= \a -> unStar (f a) x
+
+instance monadStar :: Monad f => Monad (Star f a)
+
+instance altStar :: Alt f => Alt (Star f a) where
+  alt (Star f) (Star g) = Star \a -> f a <|> g a
+
+instance plusStar :: Plus f => Plus (Star f a) where
+  empty = Star \_ -> empty
+
+instance alternativeStar :: Alternative f => Alternative (Star f a)
+
+instance monadZeroStar :: MonadZero f => MonadZero (Star f a)
+
+instance monadPlusStar :: MonadPlus f => MonadPlus (Star f a)
+
+instance distributiveStar :: Distributive f => Distributive (Star f a) where
+  distribute f = Star \a -> collect ((_ $ a) <<< unStar) f
+  collect f = distribute <<< map f
+
 instance profunctorStar :: Functor f => Profunctor (Star f) where
   dimap f g (Star ft) = Star (f >>> ft >>> map g)
 
@@ -25,3 +75,6 @@ instance strongStar :: Functor f => Strong (Star f) where
 instance choiceStar :: Applicative f => Choice (Star f) where
   left  (Star f) = Star $ either (map Left <<< f) (pure <<< Right)
   right (Star f) = Star $ either (pure <<< Left) (map Right <<< f)
+
+instance closedStar :: Distributive f => Closed (Star f) where
+  closed (Star f) = Star \g -> distribute (f <<< g)