From 475c982808ada1bb18d3bc9453d484057a0b3a59 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Wed, 29 Apr 2020 10:12:17 +0200 Subject: [PATCH] Add support for converting from VL getters and folds --- .../src/Data/Profunctor/Indexed.hs | 8 +- optics-vl/optics-vl.cabal | 1 + optics-vl/src/Optics/VL.hs | 82 ++++++++++++++++++- 3 files changed, 88 insertions(+), 3 deletions(-) diff --git a/indexed-profunctors/src/Data/Profunctor/Indexed.hs b/indexed-profunctors/src/Data/Profunctor/Indexed.hs index 417ef1fb..375d64b3 100644 --- a/indexed-profunctors/src/Data/Profunctor/Indexed.hs +++ b/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 diff --git a/optics-vl/optics-vl.cabal b/optics-vl/optics-vl.cabal index 52b8dd12..dca17e06 100644 --- a/optics-vl/optics-vl.cabal +++ b/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 diff --git a/optics-vl/src/Optics/VL.hs b/optics-vl/src/Optics/VL.hs index fe37259e..323abe58 100644 --- a/optics-vl/src/Optics/VL.hs +++ b/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 #-}