I'm trying to capture a symmetrical data processing pipeline using arrows, and was wondering if bidirectional composition is possible.
Control.Arrow exposes the following
-- | Left to right composition
(>>>) :: Category cat => cat a b -> cat b c -> cat a c
-- | Right to left composition
(<<<) :: Category cat => cat b c -> cat a b -> cat a c
what I'd like, but cannot work out how to express is bidirectional composition of pairs. The type is something like.
(<^>) :: Category cat => cat (a,y) (b,z) -> cat (b,x) (c,y) -> cat (a,x) (c,z)
where the first element of each pair is to composed left-to-right, and the second to be composed right-to-left.
Here's an example of a category involving pairs of forward and backwards functions.
{-# LANGUAGE TypeOperators, GADTs #-}
import Prelude hiding ((.))
import Data.Category
import Data.Category.Product
type C = (->) :**: (Op (->))
The above states that C (a,b) (c,d) is isomorphic to a pair (a->c, d->b). Pairs "compose" in the category in the natural way: the forward functions are composed forwards, the backwards functions are composed backwards.
Here are two examples:
f :: C (String, Bool) (Int, Char)
f = length :**: Op (=='a')
Note how the backwards function has to be wrapped in an Op (belongs to the "opposite" category).
g :: C (Int, Char) ([Int], Maybe Char)
g = (\x->[x,x]) :**: Op (maybe 'X' id)
Note how the "source" of g is the "target" of f. This ensures composition is possible.
composed :: C (String, Bool) ([Int], Maybe Char)
composed = g . f
test :: ([Int], Bool)
test = case composed of
(forward :**: Op backward) -> (forward "abcde", backward Nothing)
-- result: ([5,5],False)
On a more practical side, note that Data.Category and Control.Category are different beasts :-( and that the Control.Arrow library mentioned in the question uses the latter.
Still, it should be possible to define Op and :**: for Control.Category as well. Maybe it's already on hackage somewhere (?).
Some further approaches, best recorded as a separate answer.
The first imposes the additional constraint of an ArrowLoop, and is defined using a recursive arrow do notation.
From a data flow viewpoint however, no recursion is taking place.
(<->) ∷ (ArrowLoop a) ⇒ a (b,f) (c,g) → a (c,e) (d,f) → a (b,e) (d,g)
(<->) f1 f2 = proc (b, e) → do
rec
(c,g) ← f1 ↢ (b,f)
(d,f) ← f2 ↢ (c,e)
returnA ↢ (d,g)
It could equally be defined as
(<->) ∷ (ArrowLoop a) ⇒ a (b,f) (c,g) → a (c,e) (d,f) → a (b,e) (d,g)
(<->) f1 f2 = proc (b, e) → do
rec
(d,f) ← f2 ↢ (c,e)
(c,g) ← f1 ↢ (b,f)
returnA ↢ (d,g)
The second approach does not: I've yet to work out if this is a sane thing to do.
(<->) ∷ (Arrow a) ⇒ a (b,f) (c,g) → a (c,e) (d,f) → a (b,e) (d,g)
(<->) f1 f2 = proc (b, e) → do
(c,_) ← f1 ↢ (b,undefined)
(d,_) ← f2 ↢ (c,undefined)
(_,f) ← f2 ↢ (undefined,e)
(_,g) ← f1 ↢ (undefined,f)
returnA ↢ (d,g)
The following is the same as the second approach, but defined explicitly in terms of composition functions.
(<->) ∷ (Arrow a) ⇒ a (b,f) (c,g) → a (c,e) (d,f) → a (b,e) (d,g)
(<->) f g =
let toFst x = (x,undefined)
toSnd x = (undefined,x)
in
(arr toFst ⋙ f ⋙ arr fst ⋙ arr toFst ⋙ g ⋙ arr fst) ⁂
(arr snd ⋘ f ⋘ arr toSnd ⋘ arr snd ⋘ g ⋘ arr toSnd)
Related
I tried writing down joinArr :: ??? a => a r (a r b) -> a r b.
I came up with a solution which uses app, therefore narrowing the a down to ArrowApply's:
joinArr :: ArrowApply a => a r (a r b) -> a r b
joinArr g = g &&& Control.Category.id >>> app
Is it possible to have this function written down for arrows?
My guess is no.
Control.Monad.join could have been a good stand-in for >>= in the definition of the Monad type class: m >>= k = join $ k <$> m.
Having joinArr :: Arrow a => a r (a r b) (a r b) on our hands, it would be possible to write down instance Arrow a => Monad (ArrowMonad a):
m >>= k = joinArr (k <$> m)
Please note that joinArr should be slightly tweaked to be able to deal with the wrapper. If we speak of ArrowApply:
joinArr :: ArrowApply a => ArrowMonad a (ArrowMonad a b) -> ArrowMonad a b
joinArr (ArrowMonad m) = ArrowMonad $
m &&& Control.Category.id >>>
first (arr (\x -> let ArrowMonad h = x in h)) >>>
app
instance ArrowApply a => Monad (ArrowMonad a) is already implemented in the source file.
I reckon this argument not to be the best one (if it is right).
Am I right? What is the more formal way to back this up (or disprove it)?
I think the formal reason that you can’t implement a x (a x y) -> a x y using only Arrow is that this requires a notion of either application (as you tried) or currying, or rather uncurrying in this case:
uncurry :: a x (a y z) -> a (x, y) z
With that, joinArr is simply:
joinArr :: a x (a x y) -> a x y
joinArr f = dup >>> uncurry f
where dup = id &&& id
But if we can’t implement this without apply, curry, or uncurry, that means that a must be a Cartesian closed category (CCC) because we need some notion of “exponential” or higher-order arrow, which ArrowApply gives us, but Arrow only gives us a Cartesian category. (And I believe ArrowApply is equivalent to Monad because Monad is a strong monad in a CCC.)
The closest you can get with only Arrow is an Applicative, as you saw in the definition of instance (Arrow a) => Applicative (ArrowMonad a), which happens to be equivalent in power to join in the Reader monad (since there join = (<*> id)), but not the stronger monadic join:
joinArr' :: a x (x -> y) -> a x y
joinArr' f = (f &&& id) >>> arr (uncurry ($))
Note that instead of a higher-order arrow here, a x (a x y), we just reuse the (->) type.
András Kovács proposed this question in response to an answer to a previous question.
In a lens-style uniplate library for types of kind * -> * based on the class
class Uniplate1 f where
uniplate1 :: Applicative m => f a -> (forall b. f b -> m (f b)) -> m (f a)
analogous to the class for types of kind *
class Uniplate on where
uniplate :: Applicative m => on -> (on -> m on) -> m on
is it possible to implement analogs to contexts and holes, which both have the type Uniplate on => on -> [(on, on -> on)] without requiring Typeable1?
It's clear that this could be implemented in the old-style of the uniplate library which used Str to represent the structure of the data by returning a structure with a type-level list of the types of the children.
A hole could be represented by the following data type, which would replace (on, on -> on) in the signatures for contexts and holes
data Hole f a where
Hole :: f b -> (f b -> f a) -> Hole f a
holes :: Uniplate1 f => f a -> [Hole f a]
...
However, it is unclear if there is an implementation for holes which doesn't require Typeable1.
The suggested type Hole is needlessly restrictive in the return type of the function. The following type can represent everything the former Hole represents, and more, without loss of any type information.
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
data Hole f a where
Hole :: f b -> (f b -> a) -> Hole f a
If we need to have a return type of f a, we can use Hole f (f a) to represent it. Since we will be using Holes a lot, it'd be nice to have a few utility functions. Because the return type of the function in Hole is no longer constrained to be in f, we can make a Functor instance for it
instance Functor (Hole f) where
fmap f (Hole b g) = Hole b (f . g)
contexts1 can be written for either version of Hole by replacing the constructors for tuples in the uniplate library's contexts with Hole:
contexts1 :: Uniplate1 f => f a -> [Hole f (f a)]
contexts1 x = Hole x id : f (holes1 x)
where
f xs = [ Hole y (ctx . context)
| Hole child ctx <- xs
, Hole y context <- contexts1 child]
holes1 is trickier, but can still be made by modifying holes from the uniplate library. It requires a new Replace1 Applicative Functor that uses Hole instead of a tuple. Everyhwere the second field of the tuple was modified by second (f .) we replace with fmap f for the Hole.
data Replace1 f a = Replace1 {replaced1 :: [Hole f a], replacedValue1 :: a}
instance Functor (Replace1 f) where
fmap f (Replace1 xs v) = Replace1 (map (fmap f) xs) (f v)
instance Applicative (Replace1 f) where
pure v = Replace1 [] v
Replace1 xs1 f <*> Replace1 xs2 v = Replace1 (ys1 ++ ys2) (f v)
where ys1 = map (fmap ($ v)) xs1
ys2 = map (fmap (f)) xs2
holes1 :: Uniplate1 f => f a -> [Hole f (f a)]
holes1 x = replaced1 $ descendM1 (\v -> Replace1 [Hole v id] v) x
decendM1 is defined in the preceding answer. Replace and Replace1 can be unified; how to do so is described after the examples.
Let's try some examples in terms of the code in the previous question. The following utility functions on Holes will be useful.
onHole :: (forall b. f b -> c) -> Hole f a -> c
onHole f (Hole x _) = f x
inHole :: (forall b. f b -> f b) -> Hole f a -> a
inHole g (Hole x f) = f . g $ x
Examples
We'll use the following example data and function, based on the code from the preceding questions:
example = If (B True) (I 2 `Mul` I 3) (I 1)
zero :: Expression b -> Expression b
zero x = case x of
I _ -> I 0
B _ -> B False
Add _ _ -> I 0
Mul _ _ -> I 0
Eq _ _ -> B False
And _ _ -> B False
Or _ _ -> B False
If _ a _ -> zero a
Holes
sequence_ . map (onHole print) . holes1 $ example
B True
Mul (I 2) (I 3)
I 1
Contexts
sequence_ . map (onHole print) . contexts1 $ example
If (B True) (Mul (I 2) (I 3)) (I 1)
B True
Mul (I 2) (I 3)
I 2
I 3
I 1
Replacement of each context
sequence_ . map print . map (inHole zero) . contexts1 $ example
I 0
If (B False) (Mul (I 2) (I 3)) (I 1)
If (B True) (I 0) (I 1)
If (B True) (Mul (I 0) (I 3)) (I 1)
If (B True) (Mul (I 2) (I 0)) (I 1)
If (B True) (Mul (I 2) (I 3)) (I 0)
Unifying Replace
The Replace Applicative Functor can be refactored so that it doesn't know about the type of holes for either Uniplate or Uniplate1, and instead only knows that the hole is a Functor. Holes for Uniplate were using the type (on, on -> a) and essentially using fmap f = second (f .); this is the composition of the (on, ) and on-> functors.
Instead of grabbing Compose from the transformers library, we'll make a new type for a Hole for Uniplate, which will make the example code here be more consistent and self-contained.
data Hole on a = Hole on (on -> a)
instance Functor (Hole on) where
fmap f (Hole on g) = Hole on (f . g)
We'll rename our Hole from before to Hole1.
data Hole1 f a where
Hole1 :: f b -> (f b -> a) -> Hole1 f a
instance Functor (Hole1 f) where
fmap f (Hole1 b g) = Hole1 b (f . g)
Replace can drop all knowledge of either type of hole.
data Replace f a = Replace {replaced :: [f a], replacedValue :: a}
instance Functor f => Functor (Replace f) where
fmap f (Replace xs v) = Replace (map (fmap f) xs) (f v)
instance Functor f => Applicative (Replace f) where
pure v = Replace [] v
Replace xs1 f <*> Replace xs2 v = Replace (ys1 ++ ys2) (f v)
where ys1 = map (fmap ($ v)) xs1
ys2 = map (fmap (f)) xs2
Both holes and holes1 can be implemented in terms of the new Replace.
holes :: Uniplate on => on -> [Hole on on]
holes x = replaced $ descendM (\v -> Replace [Hole v id] v) x
holes1 :: Uniplate1 f => f a -> [Hole1 f (f a)]
holes1 x = replaced $ descendM1 (\v -> Replace [Hole1 v id] v) x
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'm trying to get used to the lens library for Haskell, and find myself struggling at some simple problems. For instance, let's say (for convenience) that at and _1 have the following types (this is how I understand them, at least):
at :: Ord k => k -> Lens' (Map k v) (Maybe v)
_1 :: Lens' (a, b) a
How do I combine these lenses into a lens with the following type:
maybeFst :: Ord k => k -> Lens' (Map k (a, b)) (Maybe a)
You'd like a lens like
Lens' (Maybe (a, b)) (Maybe a)
but that can't quite be a Lens since putting back Nothing affects the b as well. It can be a Getter
getA :: Getter (Maybe (a, b)) (Maybe a)
getA = to (fmap fst)
but then when you compose it you'll just wind up with a Getter as well, not a full Lens
maybeFst :: Ord k => k -> Getter (Map k (a, b)) (Maybe a)
maybeFst k = at k . getA
Probably better than that is to use a Traversal instead
maybeFstT :: Ord k => k -> Traversal' (Map k (a, b)) a
maybeFstT k = at k . _Just . _1
This will allow you to both get (using preview or toListOf) and set values at the fst of the values in your map, but you won't be able to modify its existence in the map: if the value does not exist you cannot add it and if it does exist you cannot remove it.
Finally, we can jury-rig a fake Lens which has the appropriate type, though we have to give it a default value for b
getA :: b -> Lens' (Maybe (a, b)) (Maybe a)
getA b inj Nothing = (\x -> (,b) <$> x) <$> inj Nothing
getA _ inj (Just (a, b)) = (\x -> (,b) <$> x) <$> inj (Just a)
but notice that it has some not-very-Lenslike behavior.
>>> Just (1, 2) & getA 0 .~ Nothing & preview (_Just . _2)
Nothing
>>> Nothing & getA 0 .~ Just 1
Just (1,0)
so often it's better to avoid these pseudolenses to prevent mishaps.
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.