Add support for converting from VL getters and folds

indexed-profunctors/src/Data/Profunctor/Indexed.hs

@@ -444,7 +444,6 @@ class (Choice p, Strong p) => Visiting p where
     -> p (i -> j) s t
   ivisit f = coerce . visit (\point afb -> f point $ \_ -> afb)
 
-
 instance Functor f => Visiting (StarA f) where
   visit  f (StarA point k) = StarA point $ f point k
   ivisit f (StarA point k) = StarA point $ f point (\_ -> k)
@@ -504,6 +503,13 @@ class Visiting p => Traversing p where
     :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t)
     -> p       j  a b
     -> p (i -> j) s t
+  default iwander
+    :: Coercible (p j s t) (p (i -> j) s t)
+    => (forall f. Applicative f => (i -> a -> f b) -> s -> f t)
+    -> p       j  a b
+    -> p (i -> j) s t
+  iwander f = coerce . wander (\afb -> f $ \_ -> afb)
+  {-# INLINE iwander #-}
 
 instance Applicative f => Traversing (Star f) where
   wander  f (Star k) = Star $ f k

optics-vl/optics-vl.cabal

@@ -30,6 +30,7 @@ library
   hs-source-dirs:   src
 
   build-depends: base                   >= 4.10       && <5
+               , contravariant          >= 1.5        && <1.6
                , indexed-profunctors    >= 0.1        && <0.2
                , optics-core            >= 0.2        && <0.5
                , profunctors            >= 5.0        && <6.0

optics-vl/src/Optics/VL.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 -- |
 -- Module: Optics.VL
 --
@@ -55,16 +58,27 @@ module Optics.VL
   , IxTraversalVL'
   , itraversalVL
   , itraverseOf
+  --
+  , GetterVL
+  , getterVL
+  , toGetterVL
+  , FoldVL
+  , foldVL
+  , toFoldVL
   ) where
 
 import Data.Coerce
+import Data.Functor.Const
+import Data.Functor.Contravariant
 import Data.Functor.Identity
-import Data.Profunctor.Indexed ((.#), (#.))
 import qualified Data.Profunctor as P
 import qualified Data.Profunctor.Indexed as IP
 
+import Optics.Internal.Bi
 import Optics.Internal.Optic
-import Optics.Core
+import Optics.Internal.Utils
+import Optics.Core hiding (foldVL)
+import qualified Optics.Core as O
 
 newtype WrappedIxProfunctor p i a b =
   WrapIxProfunctor { unwrapIxProfunctor :: p i a b }
@@ -109,6 +123,40 @@ instance (P.Choice p, Applicative f) => IP.Choice (WrappedProfunctor p f) where
   {-# INLINE left' #-}
   {-# INLINE right' #-}
 
+instance (P.Strong p, Functor f) => IP.Strong (WrappedProfunctor p f) where
+  first' (WrapProfunctor pafb) =
+    let shuffle (fb, c) = (, c) <$> fb
+    in WrapProfunctor (P.rmap shuffle (P.first' pafb))
+  second' (WrapProfunctor pafb) =
+    let shuffle (c, fb) = (c ,) <$> fb
+    in WrapProfunctor (P.rmap shuffle (P.second' pafb))
+  {-# INLINE first' #-}
+  {-# INLINE second' #-}
+
+instance
+  (P.Profunctor p, Contravariant f, Functor f
+  ) => Bicontravariant (WrappedProfunctor p f) where
+  contrabimap  f g (WrapProfunctor pafb) = WrapProfunctor (P.dimap f (contramap g) pafb)
+  contrafirst  f   (WrapProfunctor pafb) = WrapProfunctor (P.lmap  f               pafb)
+  contrasecond   g (WrapProfunctor pafb) = WrapProfunctor (P.rmap    (contramap g) pafb)
+  {-# INLINE contrabimap #-}
+  {-# INLINE contrafirst #-}
+  {-# INLINE contrasecond #-}
+
+instance Functor f => IP.Cochoice (WrappedProfunctor (->) f) where
+  unleft  (WrapProfunctor f) = WrapProfunctor (fmap (\(Left a)  -> a) . f . Left)
+  unright (WrapProfunctor f) = WrapProfunctor (fmap (\(Right a) -> a) . f . Right)
+  {-# INLINE unleft #-}
+  {-# INLINE unright #-}
+
+instance Applicative f => IP.Visiting (WrappedProfunctor (->) f) where
+  visit f (WrapProfunctor afb) = WrapProfunctor (f pure afb)
+  {-# INLINE visit #-}
+
+instance Applicative f => IP.Traversing (WrappedProfunctor (->) f) where
+  wander f (WrapProfunctor afb) = WrapProfunctor (f afb)
+  {-# INLINE wander #-}
+
 ----------------------------------------
 
 -- | Type synonym for a type-modifying van Laarhoven iso.
@@ -168,3 +216,33 @@ withPrismVL
   -> r
 withPrismVL o k = k (toPrismVL o)
 {-# INLINE withPrismVL #-}
+
+----------------------------------------
+
+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 o = to (getConst #. o Const)
+{-# INLINE getterVL #-}
+
+-- | Convert a 'Getter' to the van Laarhoven representation.
+toGetterVL :: Is k A_Getter => Optic' k is s a -> GetterVL s a
+toGetterVL o = unwrapProfunctor #. getOptic (castOptic @A_Getter o) .# WrapProfunctor
+{-# INLINE toGetterVL #-}
+
+----------------------------------------
+
+type FoldVL s a =
+  forall f. (Contravariant f, Applicative f) => (a -> f a) -> s -> f s
+
+-- | Build a 'Fold' from the van Laarhoven representation.
+foldVL :: FoldVL s a -> Fold s a
+foldVL o = O.foldVL $ \f -> runTraversed . getConst #. o (Const #. Traversed #. f)
+{-# INLINE foldVL #-}
+
+-- | Convert a 'Fold' to the van Laarhoven representation.
+toFoldVL :: Is k A_Fold => Optic' k is s a -> FoldVL s a
+toFoldVL o = unwrapProfunctor #. getOptic (castOptic @A_Fold o) .# WrapProfunctor
+{-# INLINE toFoldVL #-}