Skip to content

Add GetterVL and getterVL #534

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
tomjaguarpaw wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Add GetterVL and getterVL #534

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
369bf9f
Add GetterVL and getterVL
tomjaguarpaw Nov 29, 2025
2f28d4a
Add toGetterVL
tomjaguarpaw Nov 29, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 5 additions & 0 deletions indexed-profunctors/src/Data/Profunctor/Indexed.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,7 @@ module Data.Profunctor.Indexed

import Data.Coerce (Coercible, coerce)
import Data.Functor.Const
import Data.Functor.Contravariant (Contravariant (contramap))
import Data.Functor.Identity

----------------------------------------
Expand Down Expand Up @@ -408,6 +409,10 @@ instance Cochoice (IxForgetM r) where
unleft (IxForgetM k) = IxForgetM (\i -> k i . Left)
unright (IxForgetM k) = IxForgetM (\i -> k i . Right)

instance (Contravariant f, Functor f) => Cochoice (Star f) where
unleft (Star k) = Star (contramap Left . k . Left)
unright (Star k) = Star (contramap Right . k . Right)

----------------------------------------

class (Choice p, Strong p) => Visiting p where
Expand Down
19 changes: 19 additions & 0 deletions optics-core/src/Optics/Getter.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,9 +36,15 @@ module Optics.Getter
-- * Subtyping
, A_Getter
-- | <<diagrams/Getter.png Getter in the optics hierarchy>>

-- * van Laarhoven encoding
, GetterVL
, getterVL
Copy link
Contributor

@phadej phadej Nov 29, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

If you are going to add this, there should be toGetterVL as well, to form an iso.

Copy link
Contributor Author

@tomjaguarpaw tomjaguarpaw Nov 29, 2025

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Very well, added.

, toGetterVL
)
where

import Data.Functor.Contravariant (Contravariant)
import Data.Profunctor.Indexed

import Optics.Internal.Bi
Expand All @@ -65,3 +71,16 @@ views o = \f -> runForget $ getOptic (castOptic @A_Getter o) (Forget f)
to :: (s -> a) -> Getter s a
to f = Optic (lmap f . rphantom)
{-# INLINE to #-}

-- | Type synonym for a van Laarhoven getter.
type GetterVL s a =
forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s

-- | Build a getter from the van Laarhoven representation.
getterVL :: GetterVL s a -> Getter s a
getterVL g = Optic (getter g)
{-# INLINE getterVL #-}

toGetterVL :: Is k A_Getter => Optic k is s s a a -> GetterVL s a
toGetterVL o = runStar #. getOptic (castOptic @A_Getter o) .# Star
{-# INLINE toGetterVL #-}
10 changes: 10 additions & 0 deletions optics-core/src/Optics/Internal/Bi.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -7,8 +7,10 @@
module Optics.Internal.Bi where

import Data.Coerce
import Data.Functor.Const (Const(Const, getConst))
import Data.Void

import Data.Functor.Contravariant (Contravariant(contramap))
import Data.Profunctor.Indexed

-- | Class for (covariant) bifunctors.
Expand Down Expand Up @@ -48,6 +50,11 @@ instance Bicontravariant (IxForgetM r) where
contrafirst f (IxForgetM k) = IxForgetM (\i -> k i . f)
contrasecond _g (IxForgetM k) = IxForgetM k

instance (Functor f, Contravariant f) => Bicontravariant (Star f) where
contrabimap f g (Star k) = Star (contramap g . k . f)
contrafirst f (Star k) = Star (k . f)
contrasecond g (Star k) = Star (contramap g . k)

----------------------------------------

-- | If @p@ is a 'Profunctor' and a 'Bifunctor' then its left parameter must be
Expand All @@ -59,3 +66,6 @@ lphantom = first absurd . lmap absurd
-- must be phantom.
rphantom :: (Profunctor p, Bicontravariant p) => p i c a -> p i c b
rphantom = rmap absurd . contrasecond absurd

getter :: (Profunctor p, Bicontravariant p) => ((s -> Const s s) -> a -> Const s a) -> p i s c1 -> p i a c2
getter g = lmap (getConst . g Const) . rphantom
Loading