Reformulate Data.Injector in terms of profunctors for prism compatibility

injector-profunctors.patch

From 9883e42e7f6f281e7ebada6d998d5a15789c6d6d Mon Sep 17 00:00:00 2001
From: Jonathan Sterling <jon@jonmsterling.com>
Date: Wed, 23 Sep 2015 10:28:12 -0700
Subject: [PATCH 1/1] Reformulate Injector in terms of profunctors

---
 bower.json             |  2 ++
 docs/Data/Injector.md  | 15 ++++++-----
 src/Data/Injector.purs | 72 ++++++++++++++++++++++++++++++++++++++++----------
 3 files changed, 69 insertions(+), 20 deletions(-)

diff --git a/bower.json b/bower.json
index e2022d0..6848d82 100644
--- a/bower.json
+++ b/bower.json
@@ -25,8 +25,10 @@
     "purescript-dom": "^0.2.6",
     "purescript-foreign": "^0.7.0",
     "purescript-free": "^0.9.0",
+    "purescript-identity": "^0.4.0",
     "purescript-maps": "^0.5.0",
     "purescript-nullable": "^0.2.0",
+    "purescript-profunctor": "^0.3.1",
     "purescript-unsafe-coerce": "^0.1.0",
     "purescript-void": "^0.3.0"
   }
diff --git a/docs/Data/Injector.md b/docs/Data/Injector.md
index ec102c8..1a78040 100644
--- a/docs/Data/Injector.md
+++ b/docs/Data/Injector.md
@@ -1,18 +1,21 @@
 ## Module Data.Injector
 
-#### `Injector`
+#### `Prism`
 
 ``` purescript
-data Injector a b
-  = Injector (a -> b) (b -> Maybe a)
+type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)
 ```
 
-##### Instances
+Compatible with `Prism` from `purescript-lens`.
+
+#### `Injector`
+
 ``` purescript
-instance semigroupoidInjector :: Semigroupoid Injector
-instance categoryInjector :: Category Injector
+type Injector s a = Prism a a s s
 ```
 
+Compatible with `PrismP` from `purescript-lens`.
+
 #### `inj`
 
 ``` purescript
diff --git a/src/Data/Injector.purs b/src/Data/Injector.purs
index 80b451a..0ee73a6 100644
--- a/src/Data/Injector.purs
+++ b/src/Data/Injector.purs
@@ -1,35 +1,79 @@
-module Data.Injector where
+module Data.Injector
+  ( Prism()
+  , Injector()
+  , inj
+  , prj
+  , injLE
+  , injLC
+  , injRE
+  , injRC
+  ) where
 
-import Prelude (Semigroupoid, Category, (<<<), const, id)
+import Prelude (Semigroup, Semigroupoid, Applicative, Category, (<<<), const, pure, map)
 
 import Control.Bind ((<=<))
 
+import Data.Const
 import Data.Either (Either(..), either)
 import Data.Functor.Coproduct (Coproduct(), coproduct, left, right)
-import Data.Maybe (Maybe(..))
+import Data.Identity
+import Data.Maybe (Maybe(..), maybe)
+import Data.Monoid
+import qualified Data.Profunctor as PF
+import qualified Data.Profunctor.Choice as PF
 
-data Injector a b = Injector (a -> b) (b -> Maybe a)
+import Unsafe.Coerce
 
-instance semigroupoidInjector :: Semigroupoid Injector where
-  compose (Injector injA prjA) (Injector injB prjB) = Injector (injA <<< injB) (prjB <=< prjA)
+-- | Compatible with `Prism` from `purescript-lens`.
+type Prism s t a b = forall p f. (PF.Choice p, Applicative f) => p a (f b) -> p s (f t)
 
-instance categoryInjector :: Category Injector where
-  id = Injector id Just
+-- | Compatible with `PrismP` from `purescript-lens`.
+type Injector s a = Prism a a s s
+
+newtype Tagged s b = Tagged b
+
+instance profunctorTagged :: PF.Profunctor Tagged where
+  dimap _ f (Tagged b) = Tagged (f b)
+
+instance choiceTagged :: PF.Choice Tagged where
+  left (Tagged b) = Tagged (Left b)
+  right (Tagged b) = Tagged (Right b)
+
+newtype First a = First (Maybe a)
+
+getFirst :: forall a. First a -> Maybe a
+getFirst (First a) = a
+
+instance firstSemigroup :: Semigroup (First a) where
+  append (First Nothing) y = y
+  append x _ = x
+
+instance firstMonoid :: Monoid (First a) where
+  mempty = First Nothing
+
+unTagged :: forall s b. Tagged s b -> b
+unTagged (Tagged b) = b
 
 inj :: forall a b. Injector a b -> a -> b
-inj (Injector f _) = f
+inj p = runIdentity <<< unTagged <<< p <<< Tagged <<< Identity
 
 prj :: forall a b. Injector a b -> b -> Maybe a
-prj (Injector _ g) = g
+prj p = getFirst <<< getConst <<< p (Const <<< First <<< Just)
+
+prism :: forall s t a b. (b -> t) -> (s -> Either t a) -> Prism s t a b
+prism f g = PF.dimap g (either pure (map f)) <<< PF.right
+
+prism' :: forall s a b. (b -> s) -> (s -> Maybe a) -> Prism s s a b
+prism' f g = prism f (\s -> maybe (Left s) Right (g s))
 
 injLE :: forall a b. Injector a (Either a b)
-injLE = Injector Left (either Just (const Nothing))
+injLE = prism' Left (either Just (const Nothing))
 
 injRE :: forall a b. Injector a (Either b a)
-injRE = Injector Right (either (const Nothing) Just)
+injRE = prism' Right (either (const Nothing) Just)
 
 injLC :: forall f g a. Injector (f a) (Coproduct f g a)
-injLC = Injector left (coproduct Just (const Nothing))
+injLC = prism' left (coproduct Just (const Nothing))
 
 injRC :: forall f g a. Injector (f a) (Coproduct g f a)
-injRC = Injector right (coproduct (const Nothing) Just)
+injRC = prism' right (coproduct (const Nothing) Just)
-- 
2.1.1