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)
Related
I was thinking about unzipping operations and realized that one way to express them is by traversing in a Biapplicative functor.
import Data.Biapplicative
class Traversable2 t where
traverse2 :: Biapplicative p
=> (a -> p b c) -> t a -> p (t b) (t c)
-- Note: sequence2 :: [(a,b)] -> ([a], [b])
sequence2 :: (Traversable2 t, Biapplicative p)
=> t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id
instance Traversable2 [] where
traverse2 _ [] = bipure [] []
traverse2 f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs
It smells to me as though every instance of Traversable can be transformed mechanically into an instance of Traversable2. But I haven't yet found a way to actually implement traverse2 using traverse, short of converting to and from lists or perhaps playing extremely dirty tricks with unsafeCoerce. Is there a nice way to do this?
Further evidence that anything Traversable is Traversable2:
class (Functor t, Foldable t) => Traversable2 t where
traverse2 :: Biapplicative p
=> (a -> p b c) -> t a -> p (t b) (t c)
default traverse2 ::
(Biapplicative p, Generic1 t, GTraversable2 (Rep1 t))
=> (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f xs = bimap to1 to1 $ gtraverse2 f (from1 xs)
class GTraversable2 r where
gtraverse2 :: Biapplicative p
=> (a -> p b c) -> r a -> p (r b) (r c)
instance GTraversable2 V1 where
gtraverse2 _ x = bipure (case x of) (case x of)
instance GTraversable2 U1 where
gtraverse2 _ _ = bipure U1 U1
instance GTraversable2 t => GTraversable2 (M1 i c t) where
gtraverse2 f (M1 t) = bimap M1 M1 $ gtraverse2 f t
instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :*: u) where
gtraverse2 f (t :*: u) = bimap (:*:) (:*:) (gtraverse2 f t) <<*>> gtraverse2 f u
instance (GTraversable2 t, GTraversable2 u) => GTraversable2 (t :+: u) where
gtraverse2 f (L1 t) = bimap L1 L1 (gtraverse2 f t)
gtraverse2 f (R1 t) = bimap R1 R1 (gtraverse2 f t)
instance GTraversable2 (K1 i c) where
gtraverse2 f (K1 x) = bipure (K1 x) (K1 x)
instance (Traversable2 f, GTraversable2 g) => GTraversable2 (f :.: g) where
gtraverse2 f (Comp1 x) = bimap Comp1 Comp1 $ traverse2 (gtraverse2 f) x
instance Traversable2 t => GTraversable2 (Rec1 t) where
gtraverse2 f (Rec1 xs) = bimap Rec1 Rec1 $ traverse2 f xs
instance GTraversable2 Par1 where
gtraverse2 f (Par1 p) = bimap Par1 Par1 (f p)
I think I might have something that fits your bill. (Edit: It doesn't, see comments.) You can define newtypes over p () c and p b () and make them Functor instances.
Implementation
Here's your class again with default definitions. I went the route of implementing sequence2 in terms of sequenceA because it seemed simpler.
class Functor t => Traversable2 t where
{-# MINIMAL traverse2 | sequence2 #-}
traverse2 :: Biapplicative p => (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f = sequence2 . fmap f
sequence2 :: Biapplicative p => t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id
Now, the "right part" of the Biapplicative is
newtype R p c = R { runR :: p () c }
instance Bifunctor p => Functor (R p) where
fmap f (R x) = R $ bimap id f x
instance Biapplicative p => Applicative (R p) where
pure x = R (bipure () x)
R f <*> R x =
let f' = biliftA2 const (flip const) (bipure id ()) f
in R $ f' <<*>> x
mkR :: Biapplicative p => p b c -> R p c
mkR = R . biliftA2 const (flip const) (bipure () ())
sequenceR :: (Traversable t, Biapplicative p) => t (p b c) -> p () (t c)
sequenceR = runR . sequenceA . fmap mkR
with the "left part" much the same. The full code is in this gist.
Now we can make p (t b) () and p () (t c) and reassemble them into p (t b) (t c).
instance (Functor t, Traversable t) => Traversable2 t where
sequence2 x = biliftA2 const (flip const) (sequenceL x) (sequenceR x)
I needed to turn on FlexibleInstances and UndecidableInstances for that instance declaration. Also, somehow ghc wanted a Functor constaint.
Testing
I verified with your instance for [] that it gives the same results:
main :: IO ()
main = do
let xs = [(x, ord x - 97) | x <- ['a'..'g']]
print xs
print (sequence2 xs)
print (sequence2' xs)
traverse2' :: Biapplicative p => (a -> p b c) -> [a] -> p [b] [c]
traverse2' _ [] = bipure [] []
traverse2' f (x : xs) = bimap (:) (:) (f x) <<*>> traverse2 f xs
sequence2' :: Biapplicative p => [p b c] -> p [b] [c]
sequence2' = traverse2' id
outputs
[('a',0),('b',1),('c',2),('d',3),('e',4),('f',5),('g',6)]
("abcdefg",[0,1,2,3,4,5,6])
("abcdefg",[0,1,2,3,4,5,6])
This was a fun exercise!
The following seems to do the trick, exploiting “only” undefined. Possibly the traversable laws guarantee that this is ok, but I've not attempted to prove it.
{-# LANGUAGE GADTs, KindSignatures, TupleSections #-}
import Data.Biapplicative
import Data.Traversable
data Bimock :: (* -> * -> *) -> * -> * where
Bimock :: p a b -> Bimock p (a,b)
Bimfmap :: ((a,b) -> c) -> p a b -> Bimock p c
Bimpure :: a -> Bimock p a
Bimapp :: Bimock p ((a,b) -> c) -> p a b -> Bimock p c
instance Functor (Bimock p) where
fmap f (Bimock p) = Bimfmap f p
fmap f (Bimfmap g p) = Bimfmap (f . g) p
fmap f (Bimpure x) = Bimpure (f x)
fmap f (Bimapp gs xs) = Bimapp (fmap (f .) gs) xs
instance Biapplicative p => Applicative (Bimock p) where
pure = Bimpure
Bimpure f<*>xs = fmap f xs
fs<*>Bimpure x = fmap ($x) fs
fs<*>Bimock p = Bimapp fs p
Bimfmap g h<*>Bimfmap i xs = Bimfmap (\(~(a₁,a₂),~(b₁,b₂)) -> g (a₁,b₁) $ i (a₂, b₂))
$ bimap (,) (,) h<<*>>xs
Bimapp g h<*>xs = fmap uncurry g <*> ((,)<$>Bimock h<*>xs)
runBimock :: Biapplicative p => Bimock p (a,b) -> p a b
runBimock (Bimock p) = p
runBimock (Bimfmap f p) = bimap (fst . f . (,undefined)) (snd . f . (undefined,)) p
runBimock (Bimpure (a,b)) = bipure a b
runBimock (Bimapp (Bimpure f) xs) = runBimock . fmap f $ Bimock xs
runBimock (Bimapp (Bimfmap h g) xs)
= runBimock . fmap (\(~(a₂,a₁),~(b₂,b₁)) -> h (a₂,b₂) (a₁,b₁))
. Bimock $ bimap (,) (,) g<<*>>xs
runBimock (Bimapp (Bimapp h g) xs)
= runBimock . (fmap (\θ (~(a₂,a₁),~(b₂,b₁)) -> θ (a₂,b₂) (a₁,b₁)) h<*>)
. Bimock $ bimap (,) (,) g<<*>>xs
traverse2 :: (Biapplicative p, Traversable t) => (a -> p b c) -> t a -> p (t b) (t c)
traverse2 f s = runBimock . fmap (\bcs->(fmap fst bcs, fmap snd bcs)) $ traverse (Bimock . f) s
sequence2 :: (Traversable t, Biapplicative p)
=> t (p b c) -> p (t b) (t c)
sequence2 = traverse2 id
And even if this is safe, I wouldn't be surprised if it gives horrible performance, what with the irrefutable patterns and quadratic (or even exponential?) tuple-tree buildup.
A few observations short of a complete, original answer.
If you have a Biapplicative bifunctor, what you can do with it is apply it to something and separate it into a pair of bifunctors isomorphic to its two components.
data Helper w a b = Helper {
left :: w a (),
right :: w () b
}
runHelper :: forall p a b. Biapplicative p => Helper p a b -> p a b
runHelper x = biliftA2 const (flip const) (left x) (right x)
makeHelper :: (Biapplicative p)
=> p a b -> Helper p a b
makeHelper w = Helper (bimap id (const ()) w)
(bimap (const ()) id w)
type Separated w a b = (w a (), w () b)
It would be possible to combine the approaches of #nnnmmm and #leftroundabout by applying fmap (makeHelper . f) to the structure s, eliminating the need for undefined, but then you would need to make Helper or its replacement an instance of some typeclass with the useful operations that let you solve the problem.
If you have a Traversable structure, what you can do is sequenceA Applicative functors (in which case your solution will look like traverse2 f = fromHelper . sequenceA . fmap (makeHelper . f), where your Applicative instance builds a pair of t structures) or traverse it using a Functor (in which case your solution will look like traverse2 f = fromHelper . traverse (g . makeHelper . f) where ...). Either way, you need to define a Functor instance, since Applicative inherits from Functor. You might try to build your Functor from <<*>> and bipure id id, or bimap, or you might work on both separated variables in the same pass.
Unfortunately, to make the types work for the Functor instance, you have to paramaterize :: p b c to a type we would informally call :: w (b,c) where the one parameter is the Cartesian product of the two parameters of p. Haskell’s type system doesn’t seem to allow this without non-standard extensions, but #leftroundabout pulls this off ably with the Bimock class. using undefined to coerce both separated functors to have the same type.
For performance, what you want to do is make no more than one traversal, which produces an object isomorphic to p (t b) (t c) that you can then convert (similar to the Naturality law). You therefore want to implement traverse2 rather than sequence2 and define sequence2 as traverse2 id, to avoid traversing twice. If you separate variables and produce something isomorphic to (p (t b) (), p () (t c)), you can then recombine them as #mmmnnn does.
In practical use, I suspect you would want to impose some additional structure on the problem. Your question kept the components b and c of the Bifunctor completely free, but in practice they will usually be either covariant or contravariant functors that can be sequenced with biliftA2 or traversed together over a Bitraversable rather than Traversable t, or perhaps even have a Semigroup, Applicative or Monad instance.
A particularly efficient optimization would be if your p is isomorphic to a Monoid whose <> operation produces a data structure isomorphic to your t. (This works for lists and binary trees; Data.ByteString.Builder is an algebraic type that has this property.) In this case, the associativity of the operation lets you transform the structure into either a strict left fold or a lazy right fold.
This was an excellent question, and although I don’t have better code than #leftroundabout for the general case, I learned a lot from working on it.
One only mildly evil way to do this is using something like Magma from lens. This seems considerably simpler than leftaroundabout's solution, although it's not beautiful either.
data Mag a b t where
Pure :: t -> Mag a b t
Map :: (x -> t) -> Mag a b x -> Mag a b t
Ap :: Mag a b (t -> u) -> Mag a b t -> Mag a b u
One :: a -> Mag a b b
instance Functor (Mag a b) where
fmap = Map
instance Applicative (Mag a b) where
pure = Pure
(<*>) = Ap
traverse2 :: forall t a b c f. (Traversable t, Biapplicative f)
=> (a -> f b c) -> t a -> f (t b) (t c)
traverse2 f0 xs0 = go m m
where
m :: Mag a x (t x)
m = traverse One xs0
go :: forall x y. Mag a b x -> Mag a c y -> f x y
go (Pure t) (Pure u) = bipure t u
go (Map f x) (Map g y) = bimap f g (go x y)
go (Ap fs xs) (Ap gs ys) = go fs gs <<*>> go xs ys
go (One x) (One y) = f0 x
go _ _ = error "Impossible"
Given a simple "language":
data Expr a where
ConstE :: a -> Expr a
FMapE :: (b -> a) -> Expr b -> Expr a
instance Functor Expr where
fmap = FMapE
interpret :: Expr a -> a
interpret (ConstE a) = a
interpret (FMapE f a) = f (interpret a)
From that I would like to extract a call graph, eg:
foo = fmap show . fmap (*2) $ ConstE 1
Should result in the graph Node 1 -> Node (*2) -> Node show. Ideally I'd like to store this in a Data.Graph.
What I've come up to this point is that it should be possible to use System.Mem.StableNames to identify individual nodes and store them in a HashMap (StableName (Expr a)) (Expr a).
toHashMap :: Expr a -> HashMap (StableName (Expr a)) (Expr a)
toHashMap n#ConstE = do
sn <- makeStableName n
return $ HashMap.singleton sn n
The problem is, that there seems to be no way to get through the FMapE nodes:
toHashMap n#(FMapE _ a) = do
snN <- makeStableName n
snA <- makeStableName a
-- recurse
hmA <- toHashMap a
-- combine
return $ HashMap.singleton snN n `HashMap.union` hmA
GHC will complain along the lines of this:
Couldn't match type ‘t’ with ‘b’
because type variable ‘b’ would escape its scope
This (rigid, skolem) type variable is bound by
a pattern with constructor
FMapE :: forall a b. (b -> a) -> Expr b -> Expr a,
in an equation for ‘toHashMap’
I can see that this won't match ... but I have no clue on how to make this work.
Edit
This probably boils down to writing a children function:
children :: Event a -> [Event a]
children (ConstE) = []
children (FMapE _ a) = [a] -- doesn't match ...
For the same reason I can't uniplate on this ...
You can get a postorder traversal, which is a tolopogical sort for a tree, of a type of kind * -> * from the Uniplate1 class I've described previously.
{-# LANGUAGE RankNTypes #-}
import Control.Applicative
import Control.Monad.Identity
class Uniplate1 f where
uniplate1 :: Applicative m => f a -> (forall b. f b -> m (f b)) -> m (f a)
descend1 :: (forall b. f b -> f b) -> f a -> f a
descend1 f x = runIdentity $ descendM1 (pure . f) x
descendM1 :: Applicative m => (forall b. f b -> m (f b)) -> f a -> m (f a)
descendM1 f a = uniplate1 a f
transform1 :: Uniplate1 f => (forall b. f b -> f b) -> f a -> f a
transform1 f = f . descend1 (transform1 f)
transform1 is a generic postorder tranformation. A generic postorder Monadic traversal of a Uniplate1 is
transformM1 :: (Uniplate1 f, Applicative m, Monad m) =>
(forall b. f b -> m (f b)) ->
f a -> m (f a)
transformM1 f = (>>= f) . descendM1 (transformM1 f)
We can write a Uniplate1 instance for Expr:
instance Uniplate1 Expr where
uniplate1 e p = case e of
FMapE f a -> FMapE f <$> p a
e -> pure e
We'll make a simple dump function for demonstration purposes and bypass to restore the data after a monadic effect.
dump :: Expr b -> IO ()
dump (ConstE _) = putStrLn "ConstE"
dump (FMapE _ _) = putStrLn "FMapE"
bypass :: Monad m => (a -> m ()) -> a -> m a
bypass f x = f x >> return x
We can traverse your example in topological order
> transformM1 (bypass dump) (fmap show . fmap (*2) $ ConstE 1)
ConstE
FMapE
FMapE
Applicative's has the (<*>) function:
(<*>) :: (Applicative f) => f (a -> b) -> f a -> f b
Learn You a Haskell shows the following function.
Given:
ap :: (Monad m) => m (a -> b) -> m a -> m b
ap f m = do
g <- f -- '<-' extracts f's (a -> b) from m (a -> b)
m2 <- m -- '<-' extracts a from m a
return (g m2) -- g m2 has type `b` and return makes it a Monad
How could ap be written with bind alone, i.e. >>=?
I'm not sure how to extract the (a -> b) from m (a -> b). Perhaps once I understand how <- works in do notation, I'll understand the answer to my above question.
How could ap be written with bind alone, i.e. >>= ?
This is one sample implementation I can come up with:
ap :: (Monad m) => m (a -> b) -> m a -> m b
ap xs a = xs >>= (\f -> liftM f a)
Of if you don't want to even use liftM then:
ap :: (Monad m) => m (a -> b) -> m a -> m b
ap mf ma = mf >>= (\f -> ma >>= (\a' -> return $ f a'))
Intially these are the types:
mf :: m (a -> b)
ma :: m a
Now, when you apply bind (>>=) operator to mf: mf >>= (\f-> ..., then f has the type of:
f :: (a -> b)
In the next step, ma is also applied with >>=: ma >>= (\a'-> ..., here a' has the type of:
a' :: a
So, now when you apply f a', you get the type b from that because:
f :: (a -> b)
a' :: a
f a' :: b
And you apply return over f a' which will wrap it with the monadic layer and hence the final type you get will be:
return (f a') :: m b
And hence everything typechecks.
Using type families, we can define the function fold over a type and the underlying algebra for that type represented as an n-tuple of functions and constant values. This permits the definition of a generalized foldr function, defined in the Foldable type class:
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Set as S
import qualified Data.Map as M
class Foldable m where
type Algebra m b :: *
fold :: Algebra m b -> m -> b
instance (Ord a) => Foldable (Set a) where
type Algebra (Set a) b = (b, a -> b -> b)
fold = uncurry $ flip S.fold
instance (Ord k) => Foldable (Map k a) where
type Algebra (Map k a) b = (b, k -> a -> b -> b)
fold = uncurry $ flip M.foldWithKey
Similarly, constraint kinds permit the definition of a generalized map function. The map function differs from fmap by considering each value field of an algebraic data type:
class Mappable m where
type Contains m :: *
type Mapped m r b :: Constraint
map :: (Mapped m r b) => (Contains m -> b) -> m -> r
instance (Ord a) => Mappable (Set a) where
type Contains (Set a) = a
type Mapped (Set a) r b = (Ord b, r ~ Set b)
map = S.map
instance (Ord k) => Mappable (Map k a) where
type Contains (Map k a) = (k, a)
type Mapped (Map k a) r b = (Ord k, r ~ Map k b)
map = M.mapWithKey . curry
From the user's perspective, neither function is particularly friendly. In particular, neither technique permits the definition of curried functions. This means that the user cannot easily apply either fold or the mapped function partially. What I would like is a type-level function that curries tuples of functions and values, in order to generate curried versions of the above. Thus, I would like to write something approximating the following type-function:
Curry :: Product -> Type -> Type
Curry () m = m
Curry (a × as) m = a -> (Curry as m b)
If so, we could generate a curried fold function from the underlying algebra. For instance:
fold :: Curry (Algebra [a] b) ([a] -> b)
≡ fold :: Curry (b, a -> b -> b) ([a] -> b)
≡ fold :: b -> (Curry (a -> b -> b)) ([a] -> b)
≡ fold :: b -> (a -> b -> b -> (Curry () ([a] -> b))
≡ fold :: b -> ((a -> b -> b) -> ([a] -> b))
map :: (Mapped (Map k a) r b) => (Curry (Contains (Map k a)) b) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (Curry (k, a) b) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (k -> (Curry (a) b) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (k -> (a -> Curry () b)) -> Map k a -> r
≡ map :: (Mapped (Map k a) r b) => (k -> (a -> b)) -> Map k a -> r
I know that Haskell doesn't have type functions, and the proper representation of the n-tuple would probably be something like a type-level length-indexed list of types. Is this possible?
EDIT: For completeness, my current attempt at a solution is attached below. I am using empty data types to represent products of types, and type families to represent the function Curry, above. This solution appears to work for the map function, but not the fold function. I believe, but am not certain, that Curry is not being reduced properly when type checking.
data Unit
data Times a b
type family Curry a m :: *
type instance Curry Unit m = m
type instance Curry (Times a l) m = a -> Curry l m
class Foldable m where
type Algebra m b :: *
fold :: Curry (Algebra m b) (m -> b)
instance (Ord a) => Foldable (Set a) where
type Algebra (Set a) b = Times (a -> b -> b) (Times b Unit)
fold = S.fold
instance (Ord k) => Foldable (Map k a) where
type Algebra (Map k a) b = Times (k -> a -> b -> b) (Times b Unit)
fold = M.foldWithKey
class Mappable m where
type Contains m :: *
type Mapped m r b :: Constraint
map :: (Mapped m r b) => Curry (Contains m) b -> m -> r
instance (Ord a) => Mappable (Set a) where
type Contains (Set a) = Times a Unit
type Mapped (Set a) r b = (Ord b, r ~ Set b)
map = S.map
instance (Ord k) => Mappable (Map k a) where
type Contains (Map k a) = Times k (Times a Unit)
type Mapped (Map k a) r b = (Ord k, r ~ Map k b)
map = M.mapWithKey
Ok, if I understand you correctly, you can create inconvenient folds, but want to have convenient curried folds.
Below is an explanation how to achieve this as a separate step. Yes, it can also be done all at once, I've done something similar before. However, I think the separate phase makes it clearer what's going on.
We need the following language extensions:
{-# LANGUAGE TypeFamilies, TypeOperators, FlexibleInstances #-}
I'm using the following product and unit types:
data U = U
data a :*: b = a :*: b
infixr 8 :*:
As an example, let's assume we have an inconvenient version of a fold on lists:
type ListAlgType a r = (U -> r)
:*: (a :*: r :*: U -> r)
:*: U
inconvenientFold :: ListAlgType a r -> [a] -> r
inconvenientFold (nil :*: cons :*: U) [] = nil U
inconvenientFold a#(nil :*: cons :*: U) (x : xs) = cons (x :*: inconvenientFold a xs :*: U)
We have a nested product type, and we want to curry both levels. I'm defining two type classes for this, one for each layer. (It might be doable with one more general function, I haven't tried in this case.)
class CurryInner a where
type CurryI a k :: *
curryI :: (a -> b) -> CurryI a b
uncurryI :: CurryI a b -> a -> b
class CurryOuter a where
type CurryO a k :: *
curryO :: (a -> b) -> CurryO a b
uncurryO :: CurryO a b -> (a -> b) -- not really required here
Each type class implements the isomorphism between the curried and uncurried types. The type classes look identical, but CurryOuter will call CurryInner for each component of the outer nested tuple.
The instances are relatively straightforward:
instance CurryInner U where
type CurryI U k = k
curryI f = f U
uncurryI x = \ U -> x
instance CurryInner ts => CurryInner (t :*: ts) where
type CurryI (t :*: ts) k = t -> CurryI ts k
curryI f = \ t -> curryI (\ ts -> f (t :*: ts))
uncurryI f = \ (t :*: ts) -> uncurryI (f t) ts
instance CurryOuter U where
type CurryO U k = k
curryO f = f U
uncurryO x = \ U -> x
instance (CurryInner a, CurryOuter ts) => CurryOuter ((a -> b) :*: ts) where
type CurryO ((a -> b) :*: ts) k = CurryI a b -> CurryO ts k
curryO f = \ t -> curryO (\ ts -> f (uncurryI t :*: ts))
uncurryO f = \ (t :*: ts) -> uncurryO (f (curryI t)) ts
That's it. Note that
*Main> :kind! CurryO (ListAlgType A R) ([A] -> R)
CurryO (ListAlgType A R) ([A] -> R) :: *
= R -> (A -> R -> R) -> [A] -> R
(for suitably defined placeholder types A and R). We can use it as follows:
*Main> curryO inconvenientFold 0 (+) [1..10]
55
Edit: I now see you're actually only asking about currying the outer layer. You then only need one class, but can use the same idea. I used this example because I had written something for a sum-of-product based generic programming library which needed two levels of currying before, and thought at first you are in the same setting.
Ok, I think my other answer isn't actually really an answer to your question. Sorry for that.
In your final code, compare the types of fold and map:
fold :: Curry (Algebra m b) (m -> b)
map :: (Mapped m r b) => Curry (Contains m) b -> m -> r
There's a substantial difference here. The type of fold is just a type family application, whereas the type of map contains the final m -> r, mentioning the class parameter m. So in the case of map, it's easy for GHC to learn at which type you want to instance the class from the context.
Not so in the case of fold, unfortunately, because type families need not be injective, and therefore aren't easy to invert. So by seeing a particular type you use fold at, it's impossible for GHC to infer what m is.
The standard solution to this problem is to use a proxy argument that fixes the type of m, by defining
data Proxy m = P
and then giving fold this type instead:
fold :: Proxy m -> Curry (Algebra m b) (m -> b)
You have to adapt the instances to take and discard the proxy argument. Then you can use:
fold (P :: Proxy (Set Int)) (+) 0 (S.fromList [1..10])
or similar to call the fold function on sets.
To see more clearly why this situation is difficult for GHC to solve, consider this toy example instead:
class C a where
type F a :: *
f :: F a
instance C Bool where
type F Bool = Char -> Char
f = id
instance C () where
type F () = Char -> Char
f = toUpper
Now, if you call f 'x', there's no meaningful way for GHC to detect which instance you meant. The proxy would help here as well.
A type-level list is exactly what you need! You got very close, but you need the full power of both DataKinds and ScopedTypeVariables for this to work properly:
{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts, FlexibleInstances, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
import GHC.Exts (Constraint)
import Data.Set (Set)
import Data.Map (Map)
import qualified Data.Set as S
import qualified Data.Map as M
-- | A "multifunction" from a list of inhabitable types to an inhabitable type (curried from the start).
type family (->>) (l :: [*]) (y :: *) :: *
type instance '[] ->> y = y
type instance (x ': xs) ->> y = x -> (xs ->> y)
class Foldable (m :: *) where
type Algebra m (b :: *) :: [*]
fold :: forall (b :: *). Algebra m b ->> (m -> b)
instance (Ord a) => Foldable (Set a) where
type Algebra (Set a) b = '[(a -> b -> b), b]
fold = S.fold :: forall (b :: *). (a -> b -> b) -> b -> Set a -> b
instance (Ord k) => Foldable (Map k a) where
type Algebra (Map k a) b = '[(k -> a -> b -> b), b]
fold = M.foldWithKey :: forall (b :: *). (k -> a -> b -> b) -> b -> Map k a -> b
class Mappable m where
type Contains m :: [*]
type Mapped m (b :: *) (r :: *) :: Constraint
map :: forall (b :: *) (r :: *). Mapped m b r => (Contains m ->> b) -> m -> r
instance (Ord a) => Mappable (Set a) where
type Contains (Set a) = '[a]
type Mapped (Set a) b r = (Ord b, r ~ Set b)
map = S.map :: forall (b :: *). (Ord b) => (a -> b) -> Set a -> Set b
instance (Ord k) => Mappable (Map k a) where
type Contains (Map k a) = '[k, a]
type Mapped (Map k a) b r = r ~ Map k b
map = M.mapWithKey :: forall (b :: *). (k -> a -> b) -> Map k a -> Map k b
I want mapM over something that is traversable while passing an accumulator. I came up with:
import Control.Applicative
import Data.Traversable
import Control.Monad.State
mapAccumM :: (Applicative m, Traversable t, MonadState s m)
=> (s -> a -> m (s, b)) -> s -> t a -> m (t b)
mapAccumM f acc0 xs = put acc0 >> traverse g xs
where
g x = do
oldAcc <- get
(newAcc, y) <- f oldAcc x
put newAcc
return y
How can this be done without State monad?
roconnor answered this for me on #haskell
this solves my problem but notice that accumulator is returned in the second element of the tuple instead of the first
mapAccumM :: (Monad m, Functor m, Traversable t) => (a -> b -> m (c, a)) -> a -> t b -> m (t c)
mapAccumM f = flip (evalStateT . (Data.Traversable.traverse (StateT . (flip f))))
or to also return the accumulator:
mapAccumM' :: (Monad m, Functor m, Traversable t) => (a -> b -> m (c, a)) -> a -> t b -> m (t c, a)
mapAccumM' f = flip (runStateT . (Data.Traversable.traverse (StateT . (flip f))))