Linear lens combinators

src/Control/Optics/Linear/Internal.hs

@@ -23,24 +23,27 @@ module Control.Optics.Linear.Internal
   , _Just, _Nothing
   , traversed
     -- * Using optics
-  , get, set, gets
+  , get, set, gets, setSwap
   , match, build
   , over, over'
   , traverseOf, traverseOf'
-  , lengthOf
-  , withIso, withPrism
+  , toListOf, lengthOf
+  , withIso, withLens, withPrism
     -- * Constructing optics
-  , iso, prism
+  , iso, lens, prism
   )
   where
 
 import qualified Control.Arrow as NonLinear
 import qualified Data.Bifunctor.Linear as Bifunctor
 import Data.Bifunctor.Linear (SymmetricMonoidal)
 import Data.Profunctor.Linear
+import Data.Functor.Compose hiding (getCompose)
 import Data.Functor.Linear
 import qualified Data.Profunctor.Kleisli.Linear as Linear
 import Data.Void
+import GHC.Exts (FUN)
+import GHC.Types
 import Prelude.Linear
 import qualified Prelude as P
 
@@ -67,6 +70,10 @@ assoc = iso Bifunctor.lassoc Bifunctor.rassoc
 (.>) :: Optic_ arr a b s t -> Optic_ arr x y a b -> Optic_ arr x y s t
 Optical f .> Optical g = Optical (f P.. g)
 
+
+lens :: (s #-> (a, b #-> t)) -> Lens a b s t
+lens k = Optical $ \f -> dimap k (\(x,g) -> g $ x) (first f)
+
 prism :: (b #-> t) -> (s #-> Either t a) -> Prism a b s t
 prism b s = Optical $ \f -> dimap s (either id id) (second (rmap b f))
 
@@ -97,6 +104,9 @@ over (Optical l) f = getLA (l (LA f))
 traverseOf :: Optic_ (Linear.Kleisli f) a b s t -> (a #-> f b) -> s #-> f t
 traverseOf (Optical l) f = Linear.runKleisli (l (Linear.Kleisli f))
 
+toListOf :: Optic_ (NonLinear.Kleisli (Const [a])) a b s t -> s -> [a]
+toListOf l = gets l (\a -> [a])
+
 get :: Optic_ (NonLinear.Kleisli (Const a)) a b s t -> s -> a
 get l = gets l P.id
 
@@ -106,6 +116,9 @@ gets (Optical l) f s = getConst' (NonLinear.runKleisli (l (NonLinear.Kleisli (Co
 set :: Optic_ (->) a b s t -> b -> s -> t
 set (Optical l) x = l (const x)
 
+setSwap :: Optic_ (Linear.Kleisli (Compose (LinearArrow b) ((,) a))) a b s t -> s #-> b #-> (a, t)
+setSwap (Optical l) s = getLA (getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (LA (\b -> (a,b)))))) s))
+
 match :: Optic_ (Market a b) a b s t -> s #-> Either t a
 match (Optical l) = snd (runMarket (l (Market id Right)))
 
@@ -139,3 +152,10 @@ withIso (Optical l) f = f fro to
 withPrism :: Optic_ (Market a b) a b s t -> ((b #-> t) -> (s #-> Either t a) -> r) -> r
 withPrism (Optical l) f = f b m
   where Market b m = l (Market id Right)
+
+withLens :: Optic_ (Linear.Kleisli (Compose ((,) a) (FUN 'One b))) a b s t -> s #-> (a, b #-> t)
+withLens (Optical l) s = getCompose (Linear.runKleisli (l (Linear.Kleisli (\a -> Compose (a, id)))) s)
+
+-- linear variant of getCompose
+getCompose :: Compose f g a #-> f (g a)
+getCompose (Compose x) = x

src/Data/Functor/Linear/Internal.hs

@@ -5,6 +5,7 @@ module Data.Functor.Linear.Internal where
 
 import Prelude.Linear.Internal
 import Prelude (Maybe(..), Either(..))
+import Data.Functor.Compose
 import Data.Functor.Const
 import Data.Monoid.Linear
 import Data.Functor.Identity
@@ -97,6 +98,14 @@ instance Applicative Identity where
   pure = Identity
   Identity f <*> Identity x = Identity (f x)
 
+instance (Functor f, Functor g) => Functor (Compose f g) where
+  fmap f (Compose x) = Compose (fmap (fmap f) x)
+
+instance (Applicative f, Applicative g) => Applicative (Compose f g) where
+   pure x = Compose (pure (pure x))
+   (Compose f) <*> (Compose x) = Compose (liftA2 (<*>) f x)
+   liftA2 f (Compose x) (Compose y) = Compose (liftA2 (liftA2 f) x y)
+
 ---------------------------------
 -- Monad transformer instances --
 ---------------------------------