I have this simple Expr AST and I can easily convert it to String.
import Prelude hiding (Foldable)
import qualified Prelude
import Data.Foldable as F
import Data.Functor.Foldable
import Data.Monoid
import Control.Comonad.Cofree
data ExprF r = Const Int
| Add r r
deriving ( Show, Eq, Ord, Functor, Prelude.Foldable )
type Expr = Fix ExprF
testExpr = Fix $ Add (Fix (Const 1)) (Fix (Const 2))
convertToString :: Expr -> String
convertToString = cata $ \case
e#(Const x) -> show x
e#(Add x y) -> unwords [x, "+", y]
Now I want to add an additional data to it.
So I am trying to use Cofree
type LineNumber = Int
type Expr2 = Cofree ExprF LineNumber
I can convert Expr to Expr2
addLineNumbers :: Expr -> Expr2
addLineNumbers = cata $ \case
e#(Const _) -> 1 :< e
e -> 2 :< e
But I cannot figure out how to convert Expr2 to String
convertToString2 :: Expr2 -> String
convertToString2 = cata $ \case
e#(_ :< (Const x)) -> show x
e#(_ :< (Add x y)) -> unwords [x, "+", y]
Also, is Cofree the best way to solve this annotation problem?
An alternative way of annotating your syntax tree is to compose the annotation into the base functor.
-- constant functor
newtype K c a = K c
deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)
-- functor product
data (f :*: g) a = (:*:) { left :: f a, right :: g a }
deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable)
We're going to use the functor product to attach an annotation (inside a K) to each layer of the tree.
type AnnExpr = Fix (K LineNumber :*: ExprF)
If you can generate annotations while only inspecting a single layer of the tree (that is, your annotation-generating code can be expressed as a natural transformation) then you can use the following bit of machinery to modify the functor while keeping the fixpoint structure in place:
hoistFix :: Functor f => (forall a. f a -> g a) -> Fix f -> Fix g
hoistFix f = Fix . f . fmap (hoistFix f) . unFix
This is of limited usefulness, though, as most interesting annotations such as type-checking require traversal of the syntax tree.
You can reuse the code to tear down an Expr by simply ignoring the annotations. Given an algebra for ExprF...
-- instructions for a stack machine
data Inst = PUSH Int | ADD
type Prog = [Inst]
compile_ :: ExprF Prog -> Prog
compile_ (Const x) = [PUSH x]
compile_ (Add x y) = x ++ y ++ [ADD]
... you can use it to tear down either an Expr or an AnnExpr:
compileE :: Expr -> Prog
compileE = cata compile_
compileA :: AnnExpr -> Prog
compileA = cata (compile_ . right)
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.
I am working on creating an AST in Haskell. I want to add different annotations, such as types and location information, so I ended up using fixplate. However, I can't find any examples online and am having some difficulty.
I've set up my AST as recommended by fixplate (some striped out):
data ProgramF a
= Unary a
Operator
| Number Int
| Let { bindings :: [(Identifier, a)]
, body :: a }
type Program = Mu ProgramF
Next to add a label I created another type, and a function to add labels based on a tree traversal.
type LabelProgram = Attr ProgramF PLabel
labelProgram :: Program -> LabelProgram
labelProgram =
annMap (PLabel . show . fst) . (snd . synthAccumL (\i x -> (i + 1, (i, x))) 0)
However, beyond this I am running into some issues. For example, I am trying to write a function that does some transformation on the AST. Because it requires a label to function, I've made the type LabelProgram -> Program, but I think I am doing something wrong here. Below is a snippet of part of the function (one of the simpler parts):
toANF :: LabelProgram -> Program
toANF (Fix (Ann label (Let {bindings, body}))) = Fix $ Let bindingANF nbody
where
bindingANF = map (\(i, e) -> (i, toANF e)) bindings
nbody = toANF body
I feel like I am working at the wrong level of abstraction here. Should I be explicitly matching against Fix Ann ... and returning Fix ... like this, or am I utilizing fixplate wrong?
Additionally, I am concerned about how to generalize functions. How can I make my functions work for Programs, LabelPrograms, and TypePrograms generically?
Edit: Add an example of a function for ProgramFs with generic annotations.
Yes, at least in the case of toANF, you're using it wrong.
In toANF, note that your Let bindingANF nbody and the companion definitions of bindingANF and nbody are just a reimplementation of fmap toANF for the specific constructor Let.
That is, if you derive a Functor instance for your ProgramF, then you can re-write your toANF snippet as:
toANF :: LabelProgram -> Program
toANF (Fix (Ann label l#(Let _ _))) = Fix (fmap toANF l)
If toANF is just stripping labels, then this definition works for all constructors and not just Let, so you can drop the pattern:
toANF :: LabelProgram -> Program
toANF (Fix (Ann label l)) = Fix (fmap toANF l)
and now, as per #Regis_Kuckaertz's comment, you've just re-implemented forget which is defined as:
forget = Fix . fmap forget . unAnn . unFix
With respect to writing functions that work generically on Program, LabelProgram, etc., I think it makes more sense to write functions generic in a (single) annotation:
foo :: Attr ProgramF a -> Attr ProgramF a
and, if you really need to apply them to the unannotated program, define:
type ProgramU = Attr ProgramF ()
where the "U" in ProgramU stands for "unit". Obviously, you can easily write translators to work with Programs as ProgramUs if really needed:
toU :: Functor f => Mu f -> Attr f ()
toU = synthetise (const ())
fromU :: Functor f => Attr f () -> Mu f
fromU = forget
mapU :: (Functor f) => (Attr f () -> Attr f ()) -> Mu f -> Mu f
mapU f = fromU . f . toU
foo' :: Mu ProgramF -> Mu ProgramF
foo' = mapU foo
As a concrete -- if stupid -- example, here's a function that separates Lets with multiple bindings into nested Lets with singleton bindings (and so breaks mutually recursive bindings in the Program language). It assumes that the annotation on a multi-binding Let will be copied to each of the resulting singleton Lets:
splitBindings :: Attr ProgramF a -> Attr ProgramF a
splitBindings (Fix (Ann a (Let (x:y:xs) e)))
= Fix (Ann a (Let [x] (splitBindings (Fix (Ann a (Let (y:xs) e))))))
splitBindings (Fix e) = Fix (fmap splitBindings e)
It can be applied to an example Program:
testprog :: Program
testprog = Fix $ Unary (Fix $ Let [(Identifier "x", Fix $ Number 1),
(Identifier "y", Fix $ Number 2)]
(Fix $ Unary (Fix $ Number 3) NegOp))
NegOp
like so:
> mapU splitBindings testprog
Fix (Unary (Fix (Let {bindings = [(Identifier "x",Fix (Number 1))],
body = Fix (Let {bindings = [(Identifier "y",Fix (Number 2))],
body = Fix (Unary (Fix (Number 3)) NegOp)})})) NegOp)
>
Here's my full working example:
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wall #-}
import Data.Generics.Fixplate
data Identifier = Identifier String deriving (Show)
data PLabel = PLabel deriving (Show)
data Operator = NegOp deriving (Show)
data ProgramF a
= Unary a
Operator
| Number Int
| Let { bindings :: [(Identifier, a)]
, body :: a }
deriving (Show, Functor)
instance ShowF ProgramF where showsPrecF = showsPrec
type Program = Mu ProgramF
type LabelProgram = Attr ProgramF PLabel
splitBindings :: Attr ProgramF a -> Attr ProgramF a
splitBindings (Fix (Ann a (Let (x:y:xs) e)))
= Fix (Ann a (Let [x] (splitBindings (Fix (Ann a (Let (y:xs) e))))))
splitBindings (Fix e) = Fix (fmap splitBindings e)
toU :: Functor f => Mu f -> Attr f ()
toU = synthetise (const ())
fromU :: Functor f => Attr f () -> Mu f
fromU = forget
mapU :: (Functor f) => (Attr f () -> Attr f ()) -> Mu f -> Mu f
mapU f = fromU . f . toU
testprog :: Program
testprog = Fix $ Unary (Fix $ Let [(Identifier "x", Fix $ Number 1),
(Identifier "y", Fix $ Number 2)]
(Fix $ Unary (Fix $ Number 3) NegOp))
NegOp
main :: IO ()
main = print $ mapU splitBindings testprog
Still working on my text editor Rasa.
At the moment I'm building out the system for tracking viewports/splits (similar to vim splits). It seemed natural to me to represent this structure as a tree:
data Dir = Hor
| Vert
deriving (Show)
data Window a =
Split Dir SplitInfo (Window a) (Window a)
| Single ViewInfo a
deriving (Show, Functor, Traversable, Foldable)
This works great, I store my Views in the tree, and then I can traverse/fmap over them to alter them, it also dovetails with the lens package pretty well!
I've been learning about Recursion Schemes lately and it seems like this is a suitable use-case for them since the tree is a recursive data-structure.
I managed to figure it out well enough to build out the Fixpoint version:
data WindowF a r =
Split Dir SplitInfo r r
| Single ViewInfo a
deriving (Show, Functor)
type Window a = Fix (WindowF a)
However, now the Functor instance is used up by the r;
I've tried a few variations of
deriving instance Functor Window
But it chokes because window is a type synonym.
And:
newtype Window a = Window (Fix (WindowF a)) deriving Functor
And that fails too;
• Couldn't match kind ‘* -> *’ with ‘*’
arising from the first field of ‘Window’ (type ‘Fix (WindowF a)’)
• When deriving the instance for (Functor Window)
Is it still possible to define fmap/traverse over a? Or do I need to do these operations using recursion-schemes primitives? Do I implement Bifunctor? What would the instance implementation look like?
Rest of the types are here, the project doesn't compile because I don't have the proper Functor instance for Window...
Thanks!!
After a lot of wrestling I've come to the conclusion that a better choice is to define two data-types; a standard datatype that has the properties you want (in this case Bifunctor) and a Recursive Functor data-type for which you can define Base, Recursive and Corecursive instances for.
Here's what it looks like:
{-# language DeriveFunctor, DeriveTraversable, TypeFamilies #-}
import Data.Typeable
import Data.Bifunctor
import Data.Functor.Foldable
data BiTree b l =
Branch b (BiTree b l) (BiTree b l)
| Leaf l
deriving (Show, Typeable, Functor, Traversable, Foldable)
instance Bifunctor BiTree where
bimap _ g (Leaf x) = Leaf (g x)
bimap f g (Branch b l r) = Branch (f b) (bimap f g l) (bimap f g r)
data BiTreeF b l r =
BranchF b r r
| LeafF l
deriving (Show, Functor, Typeable)
type instance Base (BiTree a b) = BiTreeF a b
instance Recursive (BiTree a b) where
project (Leaf x) = LeafF x
project (Branch s l r) = BranchF s l r
instance Corecursive (BiTree a b) where
embed (BranchF sp x xs) = Branch sp x xs
embed (LeafF x) = Leaf x
You can now use your base type (BiTree) throughout your code like normal; and when you decide to use a recursion scheme you simply need to remember that when unpacking you use the 'F' versions of the constructors:
anyActiveWindows :: Window -> Bool
anyActiveWindows = cata alg
where alg (LeafF vw) = vw^.active
alg (BranchF _ l r) = l || r
Note that if you end up rebuilding a set of windows you'll still use the NON-F versions on the right-hand side of the =.
I've defined the following for my scenario and it works great; I've got both Functor and Bifunctor for Window as I wanted without even using a newtype:
type Window = BiTree Split View
data SplitRule =
Percentage Double
| FromStart Int
| FromEnd Int
deriving (Show)
data Dir = Hor
| Vert
deriving (Show)
data Split = Split
{ _dir :: Dir
, _splitRule :: SplitRule
} deriving (Show)
makeLenses ''Split
data View = View
{ _active :: Bool
, _bufIndex :: Int
} deriving (Show)
makeLenses ''View
Yes, you want to use the version of Fix from Data.Bifunctor.Fix:
newtype Fix p a = In { out :: p (Fix p a) a }
instance Bifunctor p => Functor (Fix p) where
fmap f (In x) = In (bimap (fmap f) f x)
You'll have to change your WindowF type to match:
data WindowF r a =
Split Dir SplitInfo r r
| Single ViewInfo a
deriving (Show, Functor)
instance Bifunctor WindowF where
bimap f _g (Split dir si x y) = Split dir si (f x) (f y)
bimap _f g (Single vi a) = Single vi (g a)
newtype Window a = Window (Fix WindowF a) deriving Functor
It's possible to use recursion-schemes with this, along with an auxiliary type:
import Data.Functor.Foldable hiding (Fix (..))
import Data.Profunctor.Unsafe
import Data.Coerce
newtype Flip p a b = Flip {unFlip :: p b a}
instance Bifunctor p => Bifunctor (Flip p) where
bimap f g (Flip x) = Flip (bimap g f x)
instance Bifunctor p => Functor (Flip p a) where
fmap = coerce (first :: (x -> y) -> p x a -> p y a)
:: forall x y . (x -> y) -> Flip p a x -> Flip p a y
type instance Base (Fix p a) = Flip p a
instance Bifunctor p => Recursive (Fix p a) where
project = Flip #. out
cata f = f . Flip . first (cata f) . out
Unfortunately, defining Recursive for the newtype-wrapped version is a little trickier:
newtype Window a = Window {getWindow :: Fix WindowF a} deriving (Functor)
type instance Base (Window a) = Flip WindowF a
instance Recursive (Window a) where
project = coerce #. project .# getWindow
cata = (. getWindow) #. cata
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.
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