I have this AST
data ExprF r = Const Int | Add r r
type Expr = Fix ExprF
and I want to compare
x = Fix $ Add (Fix (Const 1)) (Fix (Const 1))
y = Fix $ Add (Fix (Const 1)) (Fix (Const 2))
But all recursion schemes functions seems to work only with single structure
Obviously I can use recursion
eq (Fix (Const x)) (Fix (Const y)) = x == y
eq (Fix (Add x1 y1)) (Fix (Add x2 y2)) = (eq x1 x2) && (eq y1 y2)
eq _ _ = False
But I hope it is possible to use some sort of zipfold function.
Recursion schemes that act on a single argument are enough, because we can return a function from a scheme application. In this case, we can return an Expr -> Bool function from a scheme application on Expr. For efficient equality checking we only need paramorphisms:
{-# language DeriveFunctor, LambdaCase #-}
newtype Fix f = Fix (f (Fix f))
data ExprF r = Const Int | Add r r deriving (Functor, Show)
type Expr = Fix ExprF
cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = go where go (Fix ff) = f (go <$> ff)
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para f (Fix ff) = f ((\x -> (x, para f x)) <$> ff)
eqExpr :: Expr -> Expr -> Bool
eqExpr = cata $ \case
Const i -> cata $ \case
Const i' -> i == i'
_ -> False
Add a b -> para $ \case
Add a' b' -> a (fst a') && b (fst b')
_ -> False
Of course, cata is trivially implementable in terms of para:
cata' :: Functor f => (f a -> a) -> Fix f -> a
cata' f = para (\ffa -> f (snd <$> ffa)
Technically, almost all useful functions are implementable using cata, but they aren't necessarily efficient. We can implement para using cata:
para' :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para' f = snd . cata (\ffa -> (Fix (fst <$> ffa) , f ffa))
However, if we use para' in eqExpr we get quadratic complexity, since para' is always linear in the size of the input, while we can use para to peek at the topmost Expr values in constant time.
(This response uses the data-fix library because I couldn't get recursion-schemes to compile.)
We can model the diff of two trees as an anamorphism or unfolding of a "diff functor" that is based on the original functor.
Consider the following types
data DiffF func r = Diff (Fix func) (Fix func)
| Nodiff (func r)
deriving (Functor)
type ExprDiff = Fix (DiffF ExprF)
The idea is that ExprDiff will follow the "common structure" of the original Expr trees as long as it remains equal, but at the moment a difference is encountered, we switch to the Diff leaf, that stores the two subtrees that we found to be different.
The actual comparison function would be:
diffExpr :: Expr -> Expr -> ExprDiff
diffExpr e1 e2 = ana comparison (e1,e2)
where
comparison :: (Expr,Expr) -> DiffF ExprF (Expr,Expr)
comparison (Fix (Const i),Fix (Const i')) | i == i' =
Nodiff (Const i')
comparison (Fix (Add a1 a2),Fix (Add a1' a2')) =
Nodiff (Add (a1,a1') (a2,a2'))
comparison (something, otherthing) =
Diff something otherthing
The "seed" of the anamorphism is the pair of expressions we want to compare.
If we simply want a predicate Expr -> Expr -> Bool we can later use a catamorphism that detects the presence of Diff branches.
Related
I'm reading Graham Hutton book on Haskell, and don't no how to proceed in one part of an excercise. The excercise says as follows:
Given the following type expressions
data Expr a = Var a | Val Int | Add (Expr a) (Expr a) deriving Show
that contain variables of some type a, show how to make this type into instances of Functor, Applicative and Monad classes. With the aid of an example, explain what the >>= operator for this type does.
I have had problems defining the <*> operator of Applicative. The type of <*> is:
(<*>) :: Expr (a -> b) -> Expr a -> Expr b
I don't understand how (Val n) <*> mx might work, because theoretically I need to provide a Expr b, but all I have is a Expr a and no function to convert (a -> b).
I also don't understand what to do in the (Add l r) <*> mx case.
This is my implementation.
instance Functor Expr where
--fmap :: (a -> b) -> Expr a -> Expr b
fmap g (Var x) = Var (g x)
fmap g (Val n) = Val n
fmap g (Add l r) = Add (fmap g l) (fmap g r)
instance Applicative Expr where
--pure :: a -> Expr a
pure = Var
-- <*> :: Expr (a -> b) -> Expr a -> Expr b
(Var g) <*> mx = fmap g mx
--(Val n) <*> mx = ???
--(Add l r) <*> mx = ???
instance Monad Expr where
-- (>>=) :: Expr a -> (a -> Expr b) -> Expr b
(Var x) >>= g = g x
(Val n) >>= g = Val n
(Add l r) >>= g = Add (l >>= g) (r >>= g)
expr = Add (Add (Var 'a') (Val 4)) (Var 'b')
Finally, I have a doubt with respect to the >>= in the monad. The idea of this operator is to do things like substituting variables? Like:
expr >>= (\x -> if x == 'a' then Val 6 else Var x) >>= (\x -> if x == 'b' then Val 7 else Var x)
As you correctly note, in the case:
(Val n) <*> mx = ???
you have:
Val n :: Expr (a -> b)
mx :: Expr a
and you need to produce an Expr b. Do you recall the case:
fmap g (Val n) = ???
when you had:
g :: a -> b
Val n :: Expr a
and you needed to produce an Expr b? You found a solution there.
For the case:
(Add l r) <*> mx
you have:
l :: Expr (a -> b)
r :: Expr (a -> b)
mx :: Expr a
and you need to produce an Expr b. If only you had some function that could take l and mx and create an Expr b. Such a function, if it existed, would probably have signature:
someFunc :: Expr (a -> b) -> Expr a -> Expr b
Of course, with someFunc l mx and someFunc r mx, both of type Expr b, it would be a shame to only use one. If there was some way of constructing an Expr b from two Expr b parts, that would really be the bees' knees.
When you have defined pure and (>>=), one possible definition of (<*>) is
(<*>) = Control.Monad.ap
where ap is defined in the standard library as
ap :: Monad m => m (a -> b) -> m a -> m b
ap mf mx = do
f <- mf
x <- mx
pure (f x)
In fact any definition of (<*>) must be equivalent to that if there is a Monad instance.
You've slightly mis-stated what types you have available in the Val n case. You don't have an Expr a, but rather an Expr (a -> b), and no a or b at all (nor even a function from a -> b, because Val contains only an Int). In fact, this case is easy precisely because you have no useful values around: the only reasonable thing you could possibly do is produce an output using the constructor Val, because you have no way to fabricate a b from thin air. The type of Val can specialize to Val :: Int -> Expr b, and happily, you have an Int lying around, so you can write:
(Val n) <*> mx = Val n
I implemented it as follows:
{-# LANGUAGE InstanceSigs #-}
instance Functor Expr where
fmap :: (a -> b) -> Expr a -> Expr b
fmap _ (Val k) = Val k
fmap g (Var x) = Var (g x)
fmap g (Add expr1 expr2) = Add (fmap g expr1) (fmap g expr2)
instance Applicative Expr where
pure :: a -> Expr a
pure = Var
(<*>) :: Expr (a -> b) -> Expr a -> Expr b
_ <*> Val k = Val k
eg <*> Var x = fmap (\g -> g x) eg
eg <*> Add e1 e2 = Add (eg <*> e1) (eg <*> e2)
instance Monad Expr where
(>>=) :: Expr a -> (a -> Expr b) -> Expr b
Val k >>= _ = Val k
Var x >>= g = g x
Add e1 e2 >>= g = Add (e1 >>= g) (e2 >>= g)
However, I'm not sure how to answer the last part of the question. I suspect there's something missing in the Monad equations. For example, if I define the following function
simplify :: Num a => Expr a -> Expr a
simplify (Val k) = Val k
simplify (Var x) = Var x
simplify (Add expr1 expr2) = do
x <- simplify expr1
y <- simplify expr2
return (x + y)
And try to do the following, for example,
simplify (Add (Add (Var 5) (Val 12)) (Add (Val 10) (Var 8)))
I only get Val 12, which doesn't seem to make sense.
Let's say I want to have a very generic ListF data type:
{-# LANGUAGE GADTs, DataKinds #-}
data ListF :: * -> * -> * where
Nil :: List a b
Cons :: a -> b -> List a b
Now I can use this data type with Data.Fix to build an f-algebra
import qualified Data.Fix as Fx
instance Functor (ListF a :: * -> *) where
fmap f (Cons x y) = Cons x (f y)
fmap _ Nil = Nil
sumOfNums = Fx.cata f (Fx.Fix $ Cons 2 (Fx.Fix $ Cons 3 (Fx.Fix $ Cons 5 (Fx.Fix Nil))))
where
f (Cons x y) = x + y
f Nil = 0
But how I can use this very generic data type ListF to create what I consider the default Functor instance for recursive lists (mapping over each value in the list)
I guess I could use a Bifunctor (mapping over the first value, traversing the second), but I don't know how that could ever work with Data.Fix.Fix?
Quite right to construct a recursive functor by taking the fixpoint of a bifunctor, because 1 + 1 = 2. The list node structure is given as a container with 2 sorts of substructure: "elements" and "sublists".
It can be troubling that we need a whole other notion of Functor (which captures a rather specific variety of functor, despite its rather general name), to construct a Functor as a fixpoint. We can, however (as a bit of a stunt), shift to a slightly more general notion of functor which is closed under fixpoints.
type p -:> q = forall i. p i -> q i
class FunctorIx (f :: (i -> *) -> (o -> *)) where
mapIx :: (p -:> q) -> f p -:> f q
These are the functors on indexed sets, so the names are not just gratuitous homages to Goscinny and Uderzo. You can think of o as "sorts of structure" and i as "sorts of substructure". Here's an example, based on the fact that 1 + 1 = 2.
data ListF :: (Either () () -> *) -> (() -> *) where
Nil :: ListF p '()
Cons :: p (Left '()) -> p (Right '()) -> ListF p '()
instance FunctorIx ListF where
mapIx f Nil = Nil
mapIx f (Cons a b) = Cons (f a) (f b)
To exploit the choice of substructure sort, we'll need a kind of type-level case analysis. We can't get away with a type function, as
we need it to be partially applied, and that's not allowed;
we need a bit at run time to tell us which sort is present.
data Case :: (i -> *) -> (j -> *) -> (Either i j -> *) where
CaseL :: p i -> Case p q (Left i)
CaseR :: q j -> Case p q (Right j)
caseMap :: (p -:> p') -> (q -:> q') -> Case p q -:> Case p' q'
caseMap f g (CaseL p) = CaseL (f p)
caseMap f g (CaseR q) = CaseR (g q)
And now we can take the fixpoint:
data Mu :: ((Either i j -> *) -> (j -> *)) ->
((i -> *) -> (j -> *)) where
In :: f (Case p (Mu f p)) j -> Mu f p j
In each substructure position, we do a case split to see whether we should have a p-element or a Mu f p substructure. And we get its functoriality.
instance FunctorIx f => FunctorIx (Mu f) where
mapIx f (In fpr) = In (mapIx (caseMap f (mapIx f)) fpr)
To build lists from these things, we need to juggle between * and () -> *.
newtype K a i = K {unK :: a}
type List a = Mu ListF (K a) '()
pattern NilP :: List a
pattern NilP = In Nil
pattern ConsP :: a -> List a -> List a
pattern ConsP a as = In (Cons (CaseL (K a)) (CaseR as))
Now, for lists, we get
map' :: (a -> b) -> List a -> List b
map' f = mapIx (K . f . unK)
I guess I could use a Bifunctor (mapping over the first value, traversing the second), but I don't know how that could ever work with Data.Fix.Fix?
You hit the nail on the head.
The bifunctors package contains a "Fix-for-bifunctors" type which looks like this:
newtype Fix f a = In { out :: f (Fix f a) a }
Fix f is a Functor whenever f is a Bifunctor. fmap recursively fmaps f's first parameter and maps the second.
instance Bifunctor f => Functor (Fix f) where
fmap f = In . bimap (fmap f) f . out
So your List example would look like this:
data ListF r a = Nil | Cons r a
type List = Fix ListF
map :: (a -> b) -> List a -> List b
map = fmap
I have a recursive datatype which has a Functor instance:
data Expr1 a
= Val1 a
| Add1 (Expr1 a) (Expr1 a)
deriving (Eq, Show, Functor)
Now, I'm interested in modifying this datatype to support general recursion schemes, as they are described in this tutorial and this Hackage package. I managed to get the catamorphism to work:
newtype Fix f = Fix {unFix :: f (Fix f)}
data ExprF a r
= Val a
| Add r r
deriving (Eq, Show, Functor)
type Expr2 a = Fix (ExprF a)
cata :: Functor f => (f a -> a) -> Fix f -> a
cata f = f . fmap (cata f) . unFix
eval :: Expr2 Int -> Int
eval = cata $ \case
Val n -> n
Add x y -> x + y
main :: IO ()
main =
print $ eval
(Fix (Add (Fix (Val 1)) (Fix (Val 2))))
But now I can't figure out how to give Expr2 the same functor instance that the original Expr had. It seems there is a kind mismatch when trying to define the functor instance:
instance Functor (Fix (ExprF a)) where
fmap = undefined
Kind mis-match
The first argument of `Functor' should have kind `* -> *',
but `Fix (ExprF a)' has kind `*'
In the instance declaration for `Functor (Fix (ExprF a))'
How do I write a Functor instance for Expr2?
I thought about wrapping Expr2 in a newtype with newtype Expr2 a = Expr2 (Fix (ExprF a)) but then this newtype needs to be unwrapped to be passed to cata, which I don't like very much. I also don't know if it would be possible to automatically derive the Expr2 functor instance like I did with Expr1.
This is an old sore for me. The crucial point is that your ExprF is functorial in both its parameters. So if we had
class Bifunctor b where
bimap :: (x1 -> y1) -> (x2 -> y2) -> b x1 x2 -> b y1 y2
then you could define (or imagine a machine defining for you)
instance Bifunctor ExprF where
bimap k1 k2 (Val a) = Val (k1 a)
bimap k1 k2 (Add x y) = Add (k2 x) (k2 y)
and now you can have
newtype Fix2 b a = MkFix2 (b a (Fix2 b a))
accompanied by
map1cata2 :: Bifunctor b => (a -> a') -> (b a' t -> t) -> Fix2 b a -> t
map1cata2 e f (MkFix2 bar) = f (bimap e (map1cata2 e f) bar)
which in turn gives you that when you take a fixpoint in one of the parameters, what's left is still functorial in the other
instance Bifunctor b => Functor (Fix2 b) where
fmap k = map1cata2 k MkFix2
and you sort of get what you wanted. But your Bifunctor instance isn't going to be built by magic. And it's a bit annoying that you need a different fixpoint operator and a whole new kind of functor. The trouble is that you now have two sorts of substructure: "values" and "subexpressions".
And here's the turn. There is a notion of functor which is closed under fixpoints. Turn on the kitchen sink (especially DataKinds) and
type s :-> t = forall x. s x -> t x
class FunctorIx (f :: (i -> *) -> (o -> *)) where
mapIx :: (s :-> t) -> f s :-> f t
Note that "elements" come in a kind indexed over i and "structures" in a kind indexed over some other o. We take i-preserving functions on elements to o preserving functions on structures. Crucially, i and o can be different.
The magic words are "1, 2, 4, 8, time to exponentiate!". A type of kind * can easily be turned into a trivially indexed GADT of kind () -> *. And two types can be rolled together to make a GADT of kind Either () () -> *. That means we can roll both sorts of substructure together. In general, we have a kind of type level either.
data Case :: (a -> *) -> (b -> *) -> Either a b -> * where
CL :: f a -> Case f g (Left a)
CR :: g b -> Case f g (Right b)
equipped with its notion of "map"
mapCase :: (f :-> f') -> (g :-> g') -> Case f g :-> Case f' g'
mapCase ff gg (CL fx) = CL (ff fx)
mapCase ff gg (CR gx) = CR (gg gx)
So we can refunctor our bifactors as Either-indexed FunctorIx instances.
And now we can take the fixpoint of any node structure f which has places for either elements p or subnodes. It's just the same deal we had above.
newtype FixIx (f :: (Either i o -> *) -> (o -> *))
(p :: i -> *)
(b :: o)
= MkFixIx (f (Case p (FixIx f p)) b)
mapCata :: forall f p q t. FunctorIx f =>
(p :-> q) -> (f (Case q t) :-> t) -> FixIx f p :-> t
mapCata e f (MkFixIx node) = f (mapIx (mapCase e (mapCata e f)) node)
But now, we get the fact that FunctorIx is closed under FixIx.
instance FunctorIx f => FunctorIx (FixIx f) where
mapIx f = mapCata f MkFixIx
Functors on indexed sets (with the extra freedom to vary the index) can be very precise and very powerful. They enjoy many more convenient closure properties than Functors do. I don't suppose they'll catch on.
I wonder if you might be better off using the Free type:
data Free f a
= Pure a
| Wrap (f (Free f a))
deriving Functor
data ExprF r
= Add r r
deriving Functor
This has the added benefit that there are quite a few libraries that work on free monads already, so maybe they'll save you some work.
Nothing wrong with pigworker's answer, but maybe you can use a simpler one as a stepping-stone:
{-# LANGUAGE DeriveFunctor, ScopedTypeVariables #-}
import Prelude hiding (map)
newtype Fix f = Fix { unFix :: f (Fix f) }
-- This is the catamorphism function you hopefully know and love
-- already. Generalizes 'foldr'.
cata :: Functor f => (f r -> r) -> Fix f -> r
cata phi = phi . fmap (cata phi) . unFix
-- The 'Bifunctor' class. You can find this in Hackage, so if you
-- want to use this just use it from there.
--
-- Minimal definition: either 'bimap' or both 'first' and 'second'.
class Bifunctor f where
bimap :: (a -> c) -> (b -> d) -> f a b -> f c d
bimap f g = first f . second g
first :: (a -> c) -> f a b -> f c b
first f = bimap f id
second :: (b -> d) -> f a b -> f a d
second g = bimap id g
-- The generic map function. I wrote this out with
-- ScopedTypeVariables to make it easier to read...
map :: forall f a b. (Functor (f a), Bifunctor f) =>
(a -> b) -> Fix (f a) -> Fix (f b)
map f = cata phi
where phi :: f a (Fix (f b)) -> Fix (f b)
phi = Fix . first f
Now your expression language works like this:
-- This is the base (bi)functor for your expression type.
data ExprF a r = Val a
| Add r r
deriving (Eq, Show, Functor)
instance Bifunctor ExprF where
bimap f g (Val a) = Val (f a)
bimap f g (Add l r) = Add (g l) (g r)
newtype Expr a = Expr (Fix (ExprF a))
instance Functor Expr where
fmap f (Expr exprF) = Expr (map f exprF)
EDIT: Here's a link to the bifunctors package in Hackage.
The keyword type is used only as a synonymous of an existing type, maybe this is what you are looking for
newtype Expr2 a r = In { out :: (ExprF a r)} deriving Functor
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
Suppose I have definitions as follows (where cata is the catamorphism):
type Algebra f a = f a -> a
newtype Fix f = Fx (f (Fix f))
unFix :: Fix f -> f (Fix f)
unFix (Fx x) = x
cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . fmap (cata alg) . unFix
I was wondering if there would be some way to modify the definition of cata so that I could chain some object such as an int through it such that I could generate unique handles for things within the alg function, i.e. "a0", "a1", "a2", ..., etc.
Edit: To make this more clear, I'd like to be able to have some function cata' such that when I have something similar to the following definitions
data IntF a
= Const Int
| Add a a
instance Functor IntF where
fmap eval (Const i) = Const i
fmap eval (x `Add` y) = eval x `Add` eval y
alg :: Int -> Algebra IntF String
alg n (Const i) = "a" ++ show n
alg n (s1 `Add` s2) = s1 ++ " && " ++ s2
eval = cata' alg
addExpr = Fx $ (Fx $ Const 5) `Add` (Fx $ Const 4)
run = eval addExpr
then run evaluates to "a0 && a1" or something similar, i.e. the two constants don't get labeled the same thing.
Just sequence them as monads.
newtype Ctr a = Ctr { runCtr :: Int -> (a, Int) } -- is State Int
instance Functor Ctr
instance Applicative Ctr
instance Monad Ctr
type MAlgebra m f a = f (m a) -> m a
fresh :: Ctr Int
fresh = Ctr (\i -> (i, i+1))
data IntF a
= Val
| Add a a
malg :: IntF (Ctr String) -> Ctr String
malg Val = (\x -> "a" ++ show x) <$> fresh
malg (Add x y) = (\a b -> a ++ " && " ++ b) <$> x <*> y
go = cata malg
As I understand, you want something like
cata' :: Functor f => (Int -> f a -> a) -> Fix f -> a
so that you can operate both on f a and it's index.
If that's true, here's a possible solution.
Associated Int
First we define a new type which will represent Int-labelled functor:
{-# LANGUAGE DeriveFunctor #-}
data IntLabel f a = IntLabel Int (f a) deriving (Functor)
-- This acts pretty much like `zip`.
labelFix :: Functor f => [Int] -> Fix f -> Fix (IntLabel f)
labelFix (x:xs) (Fx f) = Fx . IntLabel x $ fmap (labelFix xs) f
Now we can define cata' using cata and labelFix:
cata' :: Functor f => (Int -> f a -> a) -> Fix f -> a
cata' alg = cata alg' . labelFix [1..]
where
alg' (IntLabel n f) = alg n f
NOTE: unique Ints are assigned to each layer, not each functor. E.g. for Fix [] each sublist of the outermost list will be labelled with 2.
Threading effects
A different approach to the problem would be to use cata to produce monadic value:
cata :: Functor f => (f (m a) -> m a) -> Fix f -> m a
This is just a specialized version of cata. With it we can define (almost) cat' as
cata'' :: Traversable f => (Int -> f a -> a) -> Fix f -> a
cata'' alg = flip evalState [1..] . cata alg'
where
alg' f = alg <$> newLabel <*> sequenceA f
newLabel :: State [a] a
newLabel = state (\(x:xs) -> (x, xs))
Note that Traversable instance now is needed in order to switch f (m a) to m (f a).
However, you might want to use just a bit more specialized cata:
cata :: (Functor f, MonadReader Int m) => (f (m a) -> m a) -> Fix f -> m a