Grates (#60)

Author: paf31

src/Data/Lens.purs

@@ -19,10 +19,12 @@ module Data.Lens
   , module Data.Lens.Setter
   , module Data.Lens.Getter
   , module Data.Lens.Fold
+  , module Data.Lens.Grate
   , module Data.Lens.Common
   ) where
 
 import Data.Lens.Iso (AnIso, AnIso', Iso, Iso', Optic, Exchange(..), Re(..), au, auf, cloneIso, non, curried, flipped, iso, re, uncurried, under, withIso)
+import Data.Lens.Grate (Grate, Grate', zipWithOf, zipFWithOf, collectOf)
 import Data.Lens.Lens (ALens, ALens', Lens, Lens', cloneLens, lens, lens', withLens)
 import Data.Lens.Prism (APrism, APrism', Prism, Prism', Review, Review', clonePrism, is, isn't, matching, nearly, only, prism, prism', review, withPrism)
 import Data.Lens.Traversal (Traversal, Traversal', element, elementsOf, failover, itraverseOf, sequenceOf, traverseOf, traversed)

src/Data/Lens/Grate.purs

@@ -0,0 +1,45 @@
+-- | This module defines functions for working with grates.
+-- |
+-- | See <http://r6research.livejournal.com/28050.html>.
+module Data.Lens.Grate
+  ( grate
+  , withGrate
+  , cloneGrate
+  , cotraversed
+  , zipWithOf
+  , zipFWithOf
+  , collectOf
+  , module Data.Lens.Types
+  ) where
+
+import Prelude
+import Data.Distributive (class Distributive, cotraverse)
+import Data.Lens.Internal.Grating (Grating(..))
+import Data.Lens.Internal.Zipping (Zipping(..))
+import Data.Lens.Types (Grate, Grate', Optic, AGrate)
+import Data.Newtype (unwrap)
+import Data.Profunctor (dimap)
+import Data.Profunctor.Closed (closed)
+import Data.Profunctor.Costar (Costar(..))
+import Data.Profunctor.Star (Star(..))
+
+grate :: forall s t a b. (((s -> a) -> b) -> t) -> Grate s t a b
+grate f pab = dimap (#) f (closed pab)
+
+withGrate :: forall s t a b. AGrate s t a b -> ((s -> a) -> b) -> t
+withGrate g = unwrap (g (Grating \f -> f id))
+
+cloneGrate :: forall s t a b. AGrate s t a b -> Grate s t a b
+cloneGrate g = grate (withGrate g)
+
+cotraversed :: forall f a b. Distributive f => Grate (f a) (f b) a b
+cotraversed = grate \f -> cotraverse f id
+
+zipWithOf :: forall s t a b. Optic Zipping s t a b -> (a -> a -> b) -> s -> s -> t
+zipWithOf g f = unwrap (g (Zipping f))
+
+zipFWithOf :: forall f s t a b. Optic (Costar f) s t a b -> (f a -> b) -> (f s -> t)
+zipFWithOf g f = unwrap (g (Costar f))
+
+collectOf :: forall f s t a b. Optic (Star f) s t a b -> (a -> f b) -> s -> f t
+collectOf g f = unwrap (g (Star f))

src/Data/Lens/Internal/Grating.purs

@@ -0,0 +1,16 @@
+module Data.Lens.Internal.Grating where
+
+import Prelude
+import Data.Newtype (class Newtype)
+import Data.Profunctor (class Profunctor)
+import Data.Profunctor.Closed (class Closed)
+
+newtype Grating a b s t = Grating (((s -> a) -> b) -> t)
+
+derive instance newtypeGrating :: Newtype (Grating a b s t) _
+
+instance profunctorGrating :: Profunctor (Grating a b) where
+  dimap f g (Grating z) = Grating \d -> g (z \k -> d (k <<< f))
+
+instance closedGrating :: Closed (Grating a b) where
+  closed (Grating z) = Grating \f x -> z \k -> f \g -> k (g x)

src/Data/Lens/Internal/Zipping.purs

@@ -0,0 +1,15 @@
+module Data.Lens.Internal.Zipping where
+
+import Data.Newtype (class Newtype)
+import Data.Profunctor (class Profunctor)
+import Data.Profunctor.Closed (class Closed)
+
+newtype Zipping a b = Zipping (a -> a -> b)
+
+derive instance newtypeZipping :: Newtype (Zipping a b) _
+
+instance profunctorZipping :: Profunctor Zipping where
+  dimap f g (Zipping z) = Zipping \a1 a2 -> g (z (f a1) (f a2))
+
+instance closedZipping :: Closed Zipping where
+  closed (Zipping z) = Zipping \f1 f2 x -> z (f1 x) (f2 x)

src/Data/Lens/Types.purs

@@ -6,13 +6,16 @@ module Data.Lens.Types
   , module Data.Lens.Internal.Shop
   , module Data.Lens.Internal.Tagged
   , module Data.Lens.Internal.Forget
+  , module Data.Lens.Internal.Grating
   , module Data.Lens.Internal.Wander
   , module Data.Lens.Internal.Re
   , module Data.Lens.Internal.Indexed
   ) where
 
+import Data.Tuple
 import Data.Lens.Internal.Exchange (Exchange(..))
 import Data.Lens.Internal.Forget (Forget(..))
+import Data.Lens.Internal.Grating (Grating)
 import Data.Lens.Internal.Indexed (Indexed(..))
 import Data.Lens.Internal.Market (Market(..))
 import Data.Lens.Internal.Re (Re(..))
@@ -21,8 +24,8 @@ import Data.Lens.Internal.Tagged (Tagged(..))
 import Data.Lens.Internal.Wander (class Wander, wander)
 import Data.Profunctor (class Profunctor)
 import Data.Profunctor.Choice (class Choice)
+import Data.Profunctor.Closed (class Closed)
 import Data.Profunctor.Strong (class Strong)
-import Data.Tuple
 
 -- | A general-purpose Data.Lens.
 type Optic p s t a b = p a b -> p s t
@@ -60,6 +63,13 @@ type APrism' s a = APrism s s a a
 type Traversal s t a b = forall p. Wander p => Optic p s t a b
 type Traversal' s a = Traversal s s a a
 
+-- | A grate (http://r6research.livejournal.com/28050.html)
+type Grate s t a b = forall p. Closed p => Optic p s t a b
+type Grate' s a = Grate s s a a
+
+type AGrate s t a b = Optic (Grating a b) s t a b
+type AGrate' s a = AGrate s s a a
+
 -- | A getter.
 type Getter s t a b = Fold a s t a b
 type Getter' s a = Getter s s a a

test/Main.purs

@@ -1,20 +1,22 @@
 module Test.Main where
 
 import Prelude
-
-import Data.Lens (view, traversed, _1, _2, _Just, _Left, lens)
-import Data.Lens.Index (ix)
-import Data.Lens.Setter (iover)
-import Data.Lens.Lens (ilens, IndexedLens, cloneIndexedLens)
-import Data.Lens.Fold ((^?))
-import Data.Lens.Fold.Partial ((^?!), (^@?!))
-import Data.Lens.Zoom (Traversal, Traversal', Lens, Lens', zoom)
-import Data.Tuple  (Tuple(..))
-import Data.Maybe  (Maybe(..))
-import Data.Either (Either(..))
 import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Console (CONSOLE, logShow)
 import Control.Monad.State (evalState, get)
+import Data.Distributive (class Distributive)
+import Data.Either (Either(..))
+import Data.Lens (_1, _2, _Just, _Left, collectOf, lens, traversed, view)
+import Data.Lens.Fold ((^?))
+import Data.Lens.Fold.Partial ((^?!), (^@?!))
+import Data.Lens.Grate (cloneGrate, grate, zipWithOf)
+import Data.Lens.Index (ix)
+import Data.Lens.Lens (ilens, IndexedLens, cloneIndexedLens)
+import Data.Lens.Setter (iover)
+import Data.Lens.Types (Grate)
+import Data.Lens.Zoom (Traversal, Traversal', Lens, Lens', zoom)
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..), fst, snd)
 import Partial.Unsafe (unsafePartial)
 
 -- Traversing an array nested within a record
@@ -60,6 +62,16 @@ cloneTest = iover (cloneIndexedLens i_2) Tuple (Tuple 1 2)
 i_2 :: forall a b c. IndexedLens Int (Tuple a b) (Tuple a c) b c
 i_2 = ilens (\(Tuple _ b) -> Tuple 0 b) (\(Tuple a _) b -> Tuple a b)
 
+-- Grates
+aGrateExample :: forall a b. Grate (Tuple a a) (Tuple b b) a b
+aGrateExample = grate \f -> Tuple (f fst) (f snd)
+
+collectOfTest :: forall f a b. Distributive f => (a -> f b) -> Tuple a a -> f (Tuple b b)
+collectOfTest = collectOf aGrateExample
+
+summing :: Tuple Int Int -> Tuple Int Int -> Tuple Int Int
+summing = zipWithOf (cloneGrate aGrateExample) (+)
+
 main :: forall e. Eff (console :: CONSOLE | e) Unit
 main = do
   logShow $ view bars doc
@@ -68,3 +80,4 @@ main = do
   logShow $ unsafePartial $ Tuple 0 1 ^@?! i_2
   logShow stateTest
   logShow cloneTest
+  logShow (summing (Tuple 1 2) (Tuple 3 4))