From 96377a071ce19e690d13617f00b7d6e8fdce53d6 Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Fri, 18 Sep 2020 14:58:03 +0200 Subject: [PATCH 1/2] Add setSwap combinator With a linear lens, we cannot linearly set the value at the lens site in general, however, we can swap the value at the lens site for another, which we get out of the operation. Ported from #79. --- src/Control/Optics/Linear/Internal.hs | 14 ++++++++++++-- src/Data/Functor/Linear/Internal.hs | 9 +++++++++ 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs index 4b7545e0..656964f1 100644 --- a/src/Control/Optics/Linear/Internal.hs +++ b/src/Control/Optics/Linear/Internal.hs @@ -23,11 +23,11 @@ module Control.Optics.Linear.Internal , _Just, _Nothing , traversed -- * Using optics - , get, set, gets + , get, set, gets, setSwap , match, build , over, over' , traverseOf, traverseOf' - , lengthOf + , toListOf, lengthOf , withIso, withPrism -- * Constructing optics , iso, prism @@ -38,6 +38,7 @@ 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 @@ -97,6 +98,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 +110,12 @@ 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)) + where + getCompose :: Compose f g a #-> f (g a) + getCompose (Compose x) = x + match :: Optic_ (Market a b) a b s t -> s #-> Either t a match (Optical l) = snd (runMarket (l (Market id Right))) diff --git a/src/Data/Functor/Linear/Internal.hs b/src/Data/Functor/Linear/Internal.hs index f430f687..ecbc7595 100644 --- a/src/Data/Functor/Linear/Internal.hs +++ b/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 -- --------------------------------- From 7b3056a7eb98fc1c7467a1cc22e6cd7ad6188f3b Mon Sep 17 00:00:00 2001 From: Arnaud Spiwack Date: Fri, 18 Sep 2020 15:14:26 +0200 Subject: [PATCH 2/2] Add lens and withLens combinators Translation between the profunctor definition of lens and the more straightforward getter/setter pair. Ported from #79. --- src/Control/Optics/Linear/Internal.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs index 656964f1..f748ae4d 100644 --- a/src/Control/Optics/Linear/Internal.hs +++ b/src/Control/Optics/Linear/Internal.hs @@ -28,9 +28,9 @@ module Control.Optics.Linear.Internal , over, over' , traverseOf, traverseOf' , toListOf, lengthOf - , withIso, withPrism + , withIso, withLens, withPrism -- * Constructing optics - , iso, prism + , iso, lens, prism ) where @@ -42,6 +42,8 @@ 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 @@ -68,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)) @@ -112,9 +118,6 @@ 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)) - where - getCompose :: Compose f g a #-> f (g a) - getCompose (Compose x) = x match :: Optic_ (Market a b) a b s t -> s #-> Either t a match (Optical l) = snd (runMarket (l (Market id Right))) @@ -149,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