Exactly like clowns and jokers but with the same input and output types so dissection can be repeated.

Repeated dissection

{-# LANGUAGE TypeFamilies, EmptyDataDecls, TypeOperators, FlexibleInstances, ScopedTypeVariables #-}

import Data.Maybe (catMaybes)
import Data.List (intercalate)
import Control.Applicative (liftA2)

-- Void datatypes as labels, which are easier to work with
data K a
data X
data Rec
data p :+: q
data p :*: q
data Fl p
data Fr p
data DD p

data Void
type Zero = K Void
type One = K ()

-- Mapping from label to bifunctor datatype.
data family   F p         xs r :: *
data instance F (K a)     xs r = K a
data instance F (p :+: q) xs r = L (F p xs r) | R (F q xs r)
data instance F (p :*: q) xs r = F p xs r :*: F q xs r
data instance F X         (x, t) r = X x
data instance F Rec       xs r = Rec r
data instance F (DD p)    xs r = DD (F (D p) xs r)
-- I think this one is not right:
-- data instance F (Fl p)    (x0, (x1, t)) r = Fl (F p (x0, t) r)
data instance F (Fr p)    (x0, (x1, t)) r = Fr (F p (x1, t) r)

-- Dissection operation on the labels.
type family D p :: *
type instance D (K a)     = Zero
type instance D X         = One
type instance D Rec       = DD Rec
type instance D (p :+: q) = D p :+: D q  
type instance D (p :*: q) = (D p :*: Fr q) :+: (Fl p :*: D q)
type instance D (Fl p)    = Fl (D p)
type instance D (Fr p)    = Fr (D p)
type instance D (DD p)    = DD (D p)


class Debug p where
  debug :: p -> String
  sumsOfProducts :: p -> [String] -> [Maybe [String]]
  dataDecl :: p -> Int -> String
  dataDecl p i = "data F" ++ replicate i '\'' ++ " " ++ unwords args ++ " = " ++ intercalate " | " ctors 
    where
      ctors = zipWith showCtor (catMaybes $ sumsOfProducts p args) [0..]
      showCtor ps i = "C" ++ show i ++ " " ++ unwords (fmap (\p -> "(" ++ p ++ ")") ps)
      args = fmap (('x':) . show) [0 .. i]
  
instance Debug (K Void) where
  debug _ = "0"
  sumsOfProducts _ _ = [Nothing]
instance Debug (K ()) where
  debug _ = "1"
  sumsOfProducts _ _ = [Just []]
instance Debug (K Int) where
  debug _ = "Int"
  sumsOfProducts _ _ = [Just ["Int"]]

instance Debug X where
  debug _ = "X"
  sumsOfProducts _ (x:xs) = [Just [x]]

instance Debug Rec where
  debug _ = "Rec"
  sumsOfProducts _ xs = [Just ["F " ++ unwords xs]]

instance Debug p => Debug (DD p) where
  debug _ = "(DD " ++ debug (undefined :: p) ++ ")"
  sumsOfProducts _ xs = let [Just [f:s]] = sumsOfProducts (undefined :: p) xs in [Just [f:'\'':s]]

instance (Debug p, Debug q) => Debug (p :+: q) where
  debug _ = "(" ++ debug (undefined :: p) ++ " + " ++ debug (undefined :: q)  ++ ")"
  sumsOfProducts _ xs = sumsOfProducts (undefined :: p) xs ++ sumsOfProducts (undefined :: q) xs

instance (Debug p, Debug q) => Debug (p :*: q) where
  debug _ = "(" ++ debug (undefined :: p) ++ " * " ++ debug (undefined :: q)  ++ ")"
  sumsOfProducts _ xs = 
    [ liftA2 (++) (head $ sumsOfProducts (undefined :: p) xs) (head $ sumsOfProducts (undefined :: q) xs)]

instance Debug p => Debug (Fl p) where
  debug _ = "(Fl " ++ debug (undefined :: p) ++ ")"
  sumsOfProducts _ xs = sumsOfProducts (undefined :: p) (init xs)

instance Debug p => Debug (Fr p) where
  debug _ = "(Fr " ++ debug (undefined :: p) ++ ")"
  sumsOfProducts _ xs = sumsOfProducts (undefined :: p) (tail xs)



type Tree = X :+: (Rec :*: Rec)

test0 = dataDecl (undefined :: Tree) 0
-- "data F x0 = C0 (x0) | C1 (F x0) (F x0)"

test1 = dataDecl (undefined :: D Tree) 1
-- "data F' x0 x1 = C0  | C1 (F' x0 x1) (F x1) | C2 (F x0) (F' x0 x1)"

test2 = dataDecl (undefined :: D (D Tree)) 2
-- "data F'' x0 x1 x2 = C0 (F'' x0 x1 x2) (F x2) | C1 (F' x0 x1) (F' x1 x2) | C2 (F' x0 x1) (F' x1 x2) | C3 (F x0) (F'' x0 x1 x2)"