Using a lens library I can apply a modification function to individual targets, like so:
Prelude Control.Lens> (1, 'a', 2) & _1 %~ (*3)
(3,'a',2)
Prelude Control.Lens> (1, 'a', 2) & _3 %~ (*3)
(1,'a',6)
How can I combine those individual lenses (_1 and _3) to be able to perform this update to both of the targets at once? I expect something in the spirit of the following:
Prelude Control.Lens> (1, 'a', 2) & ??? %~ (*3)
(3,'a',6)
Using untainted from the Settable type class in Control.Lens.Internal.Setter, it is possible to combine two setters, but the result will also only be a setter and not a getter.
import Control.Lens.Internal.Setter
-- (&&&) is already taken by Control.Arrow
(~&~) :: (Settable f) => (c -> d -> f a) -> (c -> a -> t) -> c -> d -> t
(~&~) a b f = b f . untainted . a f
You can test this:
>>> import Control.Lens
>>> (1, 'a', 2) & (_1 ~&~ _3) %~ (*3)
(3,'a',6)
EDIT
You don't actually need to use internal functions. You can use the fact that Mutator is a monad:
{-# LANGUAGE NoMonomorphismRestriction #-}
import Control.Monad
import Control.Applicative
(~&~) = liftA2 (>=>)
-- This works too, and is maybe easier to understand:
(~&~) a b f x = a f x >>= b f
There is a variation on what you are asking for which is more general:
(/\)
:: (Functor f)
=> ((a -> (a, a)) -> (c -> (a, c)))
-- ^ Lens' c a
-> ((b -> (b, b)) -> (c -> (b, c)))
-- ^ Lens' c b
-> (((a, b) -> f (a, b)) -> (c -> f c))
-- ^ Lens' c (a, b)
(lens1 /\ lens2) f c0 =
let (a, _) = lens1 (\a_ -> (a_, a_)) c0
(b, _) = lens2 (\b_ -> (b_, b_)) c0
fab = f (a, b)
in fmap (\(a, b) ->
let (_, c1) = lens1 (\a_ -> (a_, a)) c0
(_, c2) = lens2 (\b_ -> (b_, b)) c1
in c2
) fab
infixl 7 /\
Just focus on the type signature with lens type synonyms:
Lens' c a -> Lens' c b -> Lens' c (a, b)
It takes two lenses and combines them into a lens to a pair of fields. This is slightly more general and works for combining lenses that point to fields of different types. However, then you'd have to mutate the two fields separately.
I just wanted to throw this solution out there in case people were looking for something like this.
Related
Is there a function in the Haskell standard library which takes two functions and returns a function which will return the results of both these functions in a tuple, something like this:
(><) :: (a -> b) -> (a -> c) -> a -> (b, c)
f >< g = \a -> (f a, g a)
So that:
((+2) >< (+3)) 10 == (12,13)
((:[1,2,3]) >< (*2)) 5 == ([5,1,2,3],10)
&&& from Control.Arrow, has signature:
(&&&) :: Control.Arrow.Arrow a => a b c -> a b c' -> a b (c, c')
which is more generic than what you describe, but as shown here, when applied to functions, it resolves to:
(b -> c) -> (b -> c') -> (b -> (c, c'))
and it does what you describe:
\> import Control.Arrow ((&&&))
\> (+2) &&& (+3) $ 10
(12,13)
\> (:[1,2,3]) &&& (*2) $ 5
([5,1,2,3],10)
Use the Applicative instance for functions:
ghci> :t liftA2 (,)
liftA2 (,) :: Applicative f => f a -> f b -> f (a, b)
To make the signature more concrete, we specialize f to a function using TypeApplications (GHC >= 8):
ghci> :set -XTypeApplications
ghci> :t liftA2 #((->) _) (,)
liftA2 #((->)_) (,) :: (t -> a) -> (t -> b) -> t -> (a, b)
Lets say I have:
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
import Control.Lens
data T a b = T { _foo :: a
, _bar :: a -> b
}
makeLenses ''T
a appears in both foo and bar, so updates have to be "simulatenous", as it were. This is possible without lenses:
eg1 :: T a (b -> c) -> b -> T (a, b) c
eg1 (T foo bar) b = T (foo, b) (uncurry bar)
But how can I do this with lenses? The following doesn't work with an occurs check:
eg :: T a (b -> c) -> b -> T (a, b) c
eg t b = t & foo %~ (, b) & bar %~ uncurry
You can't do this using the automatically generated lenses for T. If you want to stretch things a bit, you can first define
data T' a b c = T' { _foo' :: c, _bar' :: a -> b}
tt :: Iso (T a b) (T a' b') (T' a b a) (T' a' b' a')
tt = dimap (\(T x g) -> T' x g) (fmap (\(T' x g) -> T x g))
Then you can (automatically) build type-changing lenses for T' and use tt to use them to modify values of type T a b through the isomorphism.
For example, rearranging the arguments a bit, you can write
eg :: b -> T a (b -> c) -> T (a, b) c
eg b = over tt $ (foo' %~ (,b)) . (bar' %~ uncurry)
Another approach that will likely be better if you don't need to fuss around with T too much is to define it as a newtype around T':
newtype T a b = T { getT :: T' a b a }
Then you can skip the Iso and just compose things. Rearranging the arguments the same way,
eg' :: b -> T a (b -> c) -> T (a, b) c
eg' b = T . (foo' %~ (,b)) . (bar' %~ uncurry) . getT
For my work with hxt I implemented the following function:
-- | Construction of a 8 argument arrow from a 8-ary function. Same
-- implementation as in #Control.Arrow.ArrowList.arr4#.
arr8 :: ArrowList a => (b1 -> b2 -> b3 -> b4 -> b5 -> b6 -> b7 -> b8 -> c)
-> a (b1, (b2, (b3, (b4, (b5, (b6, (b7, b8))))))) c
arr8 f = arr ( \ ~(x1, ~(x2, ~(x3, ~(x4, ~(x5, ~(x6, ~(x7, x8)))))))
-> f x1 x2 x3 x4 x5 x6 x7 x8 )
As mentioned in the haddock comment the above function arr8 takes an 8-ary function and returns a 8 argument arrow. I use the function like this: (x1 &&& x2 &&& ... x8) >>> arr8 f whereby x1 to x8 are arrows.
My question: Is there a way to avoid the big tuple definition? Is there a more elegant implementation of arr8?
Info: I used the same code schema as in the function arr4 (see source code of arr4)
This works, though it depends on some quite deep and fragile typeclass magic. It also requires that we change the tuple structure to be a bit more regular. In particular, it should be a type-level linked list preferring (a, (b, (c, ()))) to (a, (b, c)).
{-# LANGUAGE TypeFamilies #-}
import Control.Arrow
-- We need to be able to refer to functions presented as tuples, generically.
-- This is not possible in any straightforward method, so we introduce a type
-- family which recursively computes the desired function type. In particular,
-- we can see that
--
-- Fun (a, (b, ())) r ~ a -> b -> r
type family Fun h r :: *
type instance Fun () r = r
type instance Fun (a, h) r = a -> Fun h r
-- Then, given our newfound function specification syntax we're now in
-- the proper form to give a recursive typeclass definition of what we're
-- after.
class Zup tup where
zup :: Fun tup r -> tup -> r
instance Zup () where
zup r () = r
-- Note that this recursive instance is simple enough to not require
-- UndecidableInstances, but normally techniques like this do. That isn't
-- a terrible thing, but if UI is used it's up to the author of the typeclass
-- and its instances to ensure that typechecking terminates.
instance Zup b => Zup (a, b) where
zup f ~(a, b) = zup (f a) b
arrTup :: (Arrow a, Zup b) => Fun b c -> a b c
arrTup = arr . zup
And now we can do
> zup (+) (1, (2, ()))
3
> :t arrTup (+)
arrTup (+)
:: (Num a1, Arrow a, Zup b n, Fun n b c ~ (a1 -> a1 -> a1)) =>
a b c
> arrTup (+) (1, (2, ()))
3
If you want to define the specific variants, they're all just arrTup.
arr8
:: Arrow arr
=> (a -> b -> c -> d -> e -> f -> g -> h -> r)
-> arr (a, (b, (c, (d, (e, (f, (g, (h, ())))))))) r
arr8 = arrTup
It's finally worth noting that if we define a lazy uncurry
uncurryL :: (a -> b -> c) -> (a, b) -> c
uncurryL f ~(a, b) = f a b
then we can write the recursive branch of Zup in a way that is illustrative to what's going on here
instance Zup b => Zup (a, b) where
zup f = uncurryL (zup . f)
My approach would be writing
arr8 f = arr (uncurry8 f)
I don't know if we can write a generic uncurryN n f function (probably not), but I can offer you a pointfree uncurry_n for each n in a systematic manner like so:
uncurry3 f = uncurry ($) . cross (uncurry . f) id
uncurry4 f = uncurry ($) . cross (uncurry3 . f) id
...
uncurry8 f = uncurry ($) . cross (uncurry7 . f) id
where
cross f g = pair (f . fst) (g . snd)
pair f g x = (f x, g x)
I needed a lens function that works like over, but with monadic operations:
overM :: (Monad m) => Lens s t a b -> (a -> m b) -> (s -> m t)
While this function is easy to define (it's actually just an identity modulo WrappedMonad), I wonder are such functions defined somewhere in lens?
{-# LANGUAGE RankNTypes #-}
import Control.Applicative
import Control.Lens
overF :: (Functor f) => Lens s t a b -> (a -> f b) -> (s -> f t)
overF l = l
overM :: (Monad m) => Lens s t a b -> (a -> m b) -> (s -> m t)
overM l = (unwrapMonad .) . l . (WrapMonad .)
in Control.Lens.Traversal:
traverseOf :: Over p f s t a b -> p a (f b) -> s -> f t
traverseOf = id
mapMOf :: Profunctor p =>
Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t
mapMOf l cmd = unwrapMonad #. l (WrapMonad #. cmd)
Example:
Prelude Control.Lens> traverseOf _1 (Just . (+2)) (2,2)
Just (4,2)
Prelude Control.Lens> mapMOf _1 (Just . (+2)) (2,2)
Just (4,2)
Is there any type-safe way to write a function
bi f a b = (f a, f b)
such that it would be possible to use it like this:
x1 :: (Integer, Char)
x1 = bi head [2,3] "45"
x2 :: (Integer, Char)
x2 = bi fst (2,'3') ('4',5)
x3 :: (Integer, Double)
x3 = bi (1+) 2 3.45
?
In rank-n-types examples there are always something much simpler like
g :: (forall a. a -> a) -> a -> a -> (a, a)
g f a b = (f a, f b)
{-# LANGUAGE TemplateHaskell #-}
bi f = [| \a b -> ($f a, $f b)|]
ghci> :set -XTemplateHaskell
ghci> $(bi [|head|]) [2,3] "45"
(2,'4')
;)
Yes, though not in Haskell. But the higher-order polymorphic lambda calculus (aka System F-omega) is more general:
bi : forall m n a b. (forall a. m a -> n a) -> m a -> m b -> (n a, n b)
bi {m} {n} {a} {b} f x y = (f {a} x, f {b} y)
x1 : (Integer, Char)
x1 = bi {\a. List a} {\a. a} {Integer} {Char} head [2,3] "45"
x2 : (Integer, Char)
x2 = bi {\a . exists b. (a, b)} {\a. a} {Integer} {Char} (\{a}. \p. unpack<b,x>=p in fst {a} {b} x) (pack<Char, (2,'3')>) (pack<Integer, ('4',5)>)
x3 : (Integer, Double)
x3 = bi {\a. a} {\a. a} {Integer} {Double} (1+) 2 3.45
Here, I write f {T} for explicit type application and assume a library typed respectively. Something like \a. a is a type-level lambda. The x2 example is more intricate, because it also needs existential types to locally "forget" the other bit of polymorphism in the arguments.
You can actually simulate this in Haskell by defining a newtype or datatype for every different m or n you instantiate with, and pass appropriately wrapped functions f that add and remove constructors accordingly. But obviously, that's no fun at all.
Edit: I should point out that this still isn't a fully general solution. For example, I can't see how you could type
swap (x,y) = (y,x)
x4 = bi swap (3, "hi") (True, 3.1)
even in System F-omega. The problem is that the swap function is more polymorphic than bi allows, and unlike with x2, the other polymorphic dimension is not forgotten in the result, so the existential trick does not work. It seems that you would need kind polymorphism to allow that one (so that the argument to bi can be polymorphic over a varying number of types).
Even with ConstraintKinds, I think the barrier is going to be quantifying over the "type function" from the arguments to the results. What you want is for f to map a -> b and c -> d, and to take a -> b -> (c, d), but I don't think there's any way to quantify over that relationship with full generality.
Some special cases might be doable, though:
(forall x . cxt x => x -> f x) -> a -> b -> (f a, f b)
-- e.g. return
(forall x . cxt x => f x -> x) -> f a -> f b -> (a, b)
-- e.g. snd
(forall x . cxt x => x -> x) -> a -> b -> (a, b)
-- e.g. (+1)
but given that you're trying to quantify over more or less arbitrary type functions, I'm not sure you can make that work.
This is about as close as you're going to get, I think:
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
module Data.Function.Bi (bi, Fn(..))
bi :: (Fn i a a', Fn i b b') => i -> a -> b -> (a', b')
bi i a b = (fn i a, fn i b)
class Fn i x x' | i x -> x' where
fn :: i -> x -> x'
Use it like so:
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, RankNTypes,
FlexibleInstances, UndecidableInstances #-}
import Data.Function.Bi
data Snd = Snd
instance Fn Snd (a, b) b where
fn Snd = snd
myExpr1 :: (Int, String)
myExpr1 = bi Snd (1, 2) ("a", "b")
-- myExpr == (2, "b")
data Plus = Plus (forall a. (Num a) => a)
instance (Num a) => Fn Plus a a where
fn (Plus n) = (+n)
myExpr2 :: (Int, Double)
myExpr2 = bi (Plus 1) (1, 2) (1.3, 5.7)
-- myExpr2 == (3, 6.7)
It's very clunky, but as general as possible.