diff --git a/src/Control/Optics/Linear/Internal.hs b/src/Control/Optics/Linear/Internal.hs index 4b7545e0..f748ae4d 100644 --- a/src/Control/Optics/Linear/Internal.hs +++ b/src/Control/Optics/Linear/Internal.hs @@ -23,14 +23,14 @@ 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 @@ -38,9 +38,12 @@ 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 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 -- ---------------------------------