diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs
--- a/benchmark/Benchmark.hs
+++ b/benchmark/Benchmark.hs
@@ -42,42 +42,81 @@
 
 standardBenchmarks :: (PExpr, SugarExpr, String) -> Benchmark
 standardBenchmarks  (sExpr,aExpr,n) = rnf aExpr `seq` rnf sExpr `seq` getBench (sExpr, aExpr,n)
-    where getBench (sExpr, aExpr,n) = bgroup n [
-                 -- bench "Comp.desug" (nf A.desugExpr aExpr),
-                 -- bench "Comp.desugAlg" (nf A.desugExpr2 aExpr),
-                 -- bench "Standard.desug" (nf S.desug sExpr),
+    where getBench (sExpr, aExpr,n) = bgroup n paperBenchmarks
+          -- these are the benchmarks from the WGP '11 paper
+          paperBenchmarks = [
+                 bench "desugHom" (nf A.desugExpr aExpr),
+                 bench "desugCata" (nf A.desugExpr2 aExpr),
+                 bench "desug[Hom,Cata] (comparison)" (nf S.desug sExpr),
+                 bench "inferDesug" (nf A.desugType2 aExpr),
+                 bench "inferDesug (fusion)" (nf A.desugType2' aExpr),
+                 bench "inferDesug (comparison)" (nf S.desugType2 sExpr),
+                 bench "inferDesugM" (nf A.desugType aExpr),
+                 bench "inferDesugM (fusion)" (nf A.desugType' aExpr),
+                 bench "inferDesugM (comparison)" (nf S.desugType sExpr),
+                 bench "infer" (nf A.typeSugar2 aExpr),
+                 bench "infer (comparison)" (nf S.typeSugar2 sExpr),
+                 bench "inferM" (nf A.typeSugar aExpr),
+                 bench "inferM (comparison)" (nf S.typeSugar sExpr),
+                 bench "evalDesug" (nf A.desugEval2 aExpr),
+                 bench "evalDesug (fusion)" (nf A.desugEval2' aExpr),
+                 bench "evalDesug (comparison)" (nf S.desugEval2 sExpr),
+                 bench "evalDesugM" (nf A.desugEval aExpr),
+                 bench "evalDesugM (fusion)" (nf A.desugEval' aExpr),
+                 bench "evalDesugM (comparison)" (nf S.desugEval sExpr),
+                 bench "eval" (nf A.evalSugar2 aExpr),
+                 bench "evalDirect" (nf A.evalDirectE2 aExpr),
+                 bench "eval[Direct] (comparison)" (nf S.evalSugar2 sExpr),
+                 bench "evalM" (nf A.evalSugar aExpr),
+                 bench "evalDirectM" (nf A.evalDirectE aExpr),
+                 bench "eval[Direct]M (comparison)" (nf S.evalSugar sExpr),
+                 bench "contVar" (nf (A.contVar' 10) aExpr),
+                 bench "contVar (comparison)" (nf (S.contVar 10) sExpr),
+                 bench "contVarG" (nf (A.contVarGen 10) aExpr),
+                 bench "contVarU" (nf (S.contVarGen 10) sExpr),
+                 bench "freeVars[GU]" (nf A.freeVars' aExpr),
+                 bench "freeVarsG" (nf A.freeVarsGen aExpr),
+                 bench "freeVarsU" (nf S.freeVarsGen sExpr),
+                 bench "freeVars[GU] (comparison)" (nf S.freeVars sExpr)]
+          -- these are all the benchmarks
+          allBenchmarks = [
+                 bench "Comp.desug" (nf A.desugExpr aExpr),
+                 bench "Comp.desug'" (nf A.desugExpr' aExpr),
+                 bench "Comp.desugAlg" (nf A.desugExpr2 aExpr),
+                 bench "Standard.desug" (nf S.desug sExpr),
+                 bench "Standard.desug'" (nf S.desug' sExpr),
                  bench "Comp.desugType" (nf A.desugType aExpr),
                  bench "Comp.desugType'" (nf A.desugType' aExpr),
                  bench "Standard.desugType" (nf S.desugType sExpr),
-                 -- bench "Comp.typeSugar" (nf A.typeSugar aExpr),
-                 -- bench "Standard.typeSugar" (nf S.typeSugar sExpr),
+                 bench "Comp.typeSugar" (nf A.typeSugar aExpr),
+                 bench "Standard.typeSugar" (nf S.typeSugar sExpr),
                  bench "Comp.desugType2" (nf A.desugType2 aExpr),
                  bench "Comp.desugType2'" (nf A.desugType2' aExpr),
-                 bench "Standard.desugType2" (nf S.desugType2 sExpr)
-                 -- bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),
-                 -- bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),
-                 -- bench "Comp.desugEval" (nf A.desugEval aExpr),
-                 -- bench "Comp.desugEval'" (nf A.desugEval' aExpr),
-                 -- bench "Standard.desugEval" (nf S.desugEval sExpr),
-                 -- bench "Comp.evalSugar" (nf A.evalSugar aExpr),
-                 -- bench "Comp.evalDirect" (nf A.evalDirectE aExpr),
-                 -- bench "Standard.evalSugar" (nf S.evalSugar sExpr),
-                 -- bench "Comp.desugEval2" (nf A.desugEval2 aExpr),
-                 -- bench "Comp.desugEval2'" (nf A.desugEval2' aExpr),
-                 -- bench "Standard.desugEval2" (nf S.desugEval2 sExpr),
-                 -- bench "Comp.evalSugar2" (nf A.evalSugar2 aExpr),
-                 -- bench "Comp.evalDirect2" (nf A.evalDirectE2 aExpr),
-                 -- bench "Standard.evalSugar2" (nf S.evalSugar2 sExpr),
-                 -- bench "Comp.contVar" (nf (A.contVar 10) aExpr),
-                 -- bench "Comp.contVar'" (nf (A.contVar' 10) aExpr),
-                 -- bench "Comp.contVarGen" (nf (A.contVarGen 10) aExpr),
-                 -- bench "Standard.contVar" (nf (S.contVar 10) sExpr),
-                 -- bench "Standard.contVarGen" (nf (S.contVarGen 10) sExpr),
-                 -- bench "Comp.freeVars" (nf A.freeVars aExpr),
-                 -- bench "Comp.freeVars'" (nf A.freeVars' aExpr),
-                 -- bench "Comp.freeVarsGen" (nf A.freeVarsGen aExpr),
-                 -- bench "Standard.freeVars" (nf S.freeVars sExpr),
-                 -- bench "Standard.freeVarsGen" (nf S.freeVarsGen sExpr)
+                 bench "Standard.desugType2" (nf S.desugType2 sExpr),
+                 bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),
+                 bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),
+                 bench "Comp.desugEval" (nf A.desugEval aExpr),
+                 bench "Comp.desugEval'" (nf A.desugEval' aExpr),
+                 bench "Standard.desugEval" (nf S.desugEval sExpr),
+                 bench "Comp.evalSugar" (nf A.evalSugar aExpr),
+                 bench "Comp.evalDirect" (nf A.evalDirectE aExpr),
+                 bench "Standard.evalSugar" (nf S.evalSugar sExpr),
+                 bench "Comp.desugEval2" (nf A.desugEval2 aExpr),
+                 bench "Comp.desugEval2'" (nf A.desugEval2' aExpr),
+                 bench "Standard.desugEval2" (nf S.desugEval2 sExpr),
+                 bench "Comp.evalSugar2" (nf A.evalSugar2 aExpr),
+                 bench "Comp.evalDirect2" (nf A.evalDirectE2 aExpr),
+                 bench "Standard.evalSugar2" (nf S.evalSugar2 sExpr),
+                 bench "Comp.contVar" (nf (A.contVar 10) aExpr),
+                 bench "Comp.contVar'" (nf (A.contVar' 10) aExpr),
+                 bench "Comp.contVarGen" (nf (A.contVarGen 10) aExpr),
+                 bench "Standard.contVar" (nf (S.contVar 10) sExpr),
+                 bench "Standard.contVarGen" (nf (S.contVarGen 10) sExpr),
+                 bench "Comp.freeVars" (nf A.freeVars aExpr),
+                 bench "Comp.freeVars'" (nf A.freeVars' aExpr),
+                 bench "Comp.freeVarsGen" (nf A.freeVarsGen aExpr),
+                 bench "Standard.freeVars" (nf S.freeVars sExpr),
+                 bench "Standard.freeVarsGen" (nf S.freeVarsGen sExpr)
                                       ]
 
 randStdBenchmarks :: Int -> IO Benchmark
diff --git a/benchmark/DataTypes/Comp.hs b/benchmark/DataTypes/Comp.hs
--- a/benchmark/DataTypes/Comp.hs
+++ b/benchmark/DataTypes/Comp.hs
@@ -17,6 +17,7 @@
 import DataTypes
 import Data.Comp.Derive
 import Data.Comp
+import Data.Comp.Ops
 import Data.Comp.Arbitrary ()
 import Data.Comp.Show
 import Data.Traversable
@@ -38,13 +39,6 @@
 type BaseTypeSig = ValueT
 type BaseType = Term BaseTypeSig
 
-type HOASValueSig = Value :+: Lam
-type HOASValueExpr = Term HOASValueSig
-type HOASExprSig = Value :+: Lam :+: App :+: Op
-type HOASExpr = Term HOASExprSig
-type HOASBaseTypeSig = ValueT :+: FunT
-type HOASBaseType = Term HOASBaseTypeSig
-
 data ValueT e = TInt
               | TBool
               | TPair e e
@@ -75,28 +69,12 @@
              | Impl e e
                deriving (Eq, Functor)
 
-data FunT e = TFun e e
-              deriving (Eq, Functor)
-
-data Lam e = Lam (e -> e)
-
-data App e = App e e
-             deriving (Eq, Functor)
-
-$(derive [instanceNFData, instanceArbitrary] [''Proj])
+$(derive [makeNFData, makeArbitrary] [''Proj])
 
 $(derive
-  [instanceFoldable, instanceTraversable,
-   instanceEqF, instanceNFDataF, instanceArbitraryF, smartConstructors]
-  [''Value, ''Op, ''Sugar, ''ValueT, ''FunT, ''App])
-
-$(derive [smartConstructors] [''Lam])
-
-instance EqF Lam where
-    eqF _ _ = False
-
-instance NFDataF Lam where
-    rnfF (Lam f) = f `seq` ()
+  [makeFoldable, makeTraversable,
+   makeEqF, makeNFDataF, makeArbitraryF, smartConstructors]
+  [''Value, ''Op, ''Sugar, ''ValueT])
 
 showBinOp :: String -> String -> String -> String
 showBinOp op x y = "("++ x ++ op ++ y ++ ")"
@@ -129,16 +107,6 @@
     showF (Gt x y) = "(" ++ x ++ ">" ++ y ++ ")"
     showF (Or x y) = "(" ++ x ++ "||" ++ y ++ ")"
     showF (Impl x y) = "(" ++ x ++ "->" ++ y ++ ")"
-
-instance ShowF Lam where 
-    showF (Lam f) = "\\x. " ++ f "x"
-
-instance ShowF App where 
-    showF (App x y) = x ++ " " ++ y
-
-instance ShowF FunT where 
-    showF (TFun x y) = x ++ " -> " ++ y
-
 
 class GenTyped f where
     genTypedAlg :: CoalgM Gen f BaseType
diff --git a/benchmark/DataTypes/Standard.hs b/benchmark/DataTypes/Standard.hs
--- a/benchmark/DataTypes/Standard.hs
+++ b/benchmark/DataTypes/Standard.hs
@@ -62,58 +62,6 @@
             | VHTFun VType VType
               deriving (Eq,Typeable,Data)
 
--- HOAS
-data HOASExpr = HOASInt Int
-              | HOASBool Bool
-              | HOASPair HOASExpr HOASExpr
-              | HOASPlus HOASExpr HOASExpr
-              | HOASMult HOASExpr HOASExpr
-              | HOASIf HOASExpr HOASExpr HOASExpr
-              | HOASEq HOASExpr HOASExpr
-              | HOASLt HOASExpr HOASExpr
-              | HOASAnd HOASExpr HOASExpr
-              | HOASNot HOASExpr
-              | HOASProj SProj HOASExpr
-              | HOASApp HOASExpr HOASExpr
-              | HOASLam (HOASSExpr -> HOASExpr) -- Nasty dependency with HOASSExpr!
-              | HOASVal HOASSExpr -- Nasty dependency with HOASSExpr!
-                deriving (Typeable,Data)
-
-data HOASSExpr = HOASSInt Int
-               | HOASSBool Bool
-               | HOASSPair HOASSExpr HOASSExpr
-               | HOASSLam (HOASSExpr -> HOASSExpr)
-                 deriving (Typeable,Data)
-
-instance NFData HOASExpr where
-    rnf (HOASInt n) = rnf n `seq` ()
-    rnf (HOASBool b) = rnf b `seq` ()
-    rnf (HOASPair e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASPlus e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASMult e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASIf e1 e2 e3) = rnf e1 `seq` rnf e2 `seq` rnf e3 `seq` ()
-    rnf (HOASEq e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASLt e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASAnd e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASNot e) = rnf e `seq` ()
-    rnf (HOASProj e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASApp e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASLam e) = e `seq` ()
-    rnf (HOASVal e) = rnf e `seq` ()
-
-instance NFData HOASSExpr where
-    rnf (HOASSInt n) = rnf n `seq` ()
-    rnf (HOASSBool b) = rnf b `seq` ()
-    rnf (HOASSPair e1 e2) = rnf e1 `seq` rnf e2 `seq` ()
-    rnf (HOASSLam e) = e `seq` ()
-
-instance Eq HOASSExpr where
-    (==) (HOASSInt n1) (HOASSInt n2) = n1 == n2
-    (==) (HOASSBool b1) (HOASSBool b2) = b1 == b2
-    (==) (HOASSPair e1 e2) (HOASSPair e3 e4) = e1 == e3 && e2 == e4
-    (==) _ _ = False
-
-
 showBinOp :: String -> String -> String -> String
 showBinOp op x y = "("++ x ++ op ++ y ++ ")"
 
@@ -122,7 +70,6 @@
     show (SBool b) = show b
     show (SPair x y) = showBinOp "," (show x) (show y)
 
- 
 instance Show OExpr where
     show (OInt i) = show i
     show (OBool b) = show b
diff --git a/benchmark/DataTypes/Transform.hs b/benchmark/DataTypes/Transform.hs
--- a/benchmark/DataTypes/Transform.hs
+++ b/benchmark/DataTypes/Transform.hs
@@ -11,6 +11,7 @@
 module DataTypes.Transform where
 
 import Data.Comp
+import Data.Comp.Derive
 import DataTypes.Standard as S
 import DataTypes.Comp
 
@@ -20,9 +21,7 @@
 transSugar :: (Functor f, TransSugar f) => Term f -> PExpr
 transSugar = cata transSugarAlg
 
-instance (TransSugar f, TransSugar g) => TransSugar (f :+: g) where
-    transSugarAlg (Inl v) = transSugarAlg v
-    transSugarAlg (Inr v) = transSugarAlg v
+$(derive [liftSum] [''TransSugar])
 
 instance TransSugar Value where
     transSugarAlg (VInt i) = PInt i
@@ -56,10 +55,7 @@
 transCore :: (Functor f, TransCore f) => Term f -> OExpr
 transCore = cata transCoreAlg
 
-
-instance (TransCore f, TransCore g) => TransCore (f :+: g) where
-    transCoreAlg (Inl v) = transCoreAlg v
-    transCoreAlg (Inr v) = transCoreAlg v
+$(derive [liftSum] [''TransCore])
 
 instance TransCore Value where
     transCoreAlg (VInt i) = OInt i
@@ -84,10 +80,7 @@
 transVal :: (Functor f, TransVal f) => Term f -> SExpr
 transVal = cata transValAlg
 
-
-instance (TransVal f, TransVal g) => TransVal (f :+: g) where
-    transValAlg (Inl v) = transValAlg v
-    transValAlg (Inr v) = transValAlg v
+$(derive [liftSum] [''TransVal])
 
 instance TransVal Value where
     transValAlg (VInt i) = SInt i
@@ -100,10 +93,7 @@
 transType :: (Functor f, TransType f) => Term f -> VType
 transType = cata transTypeAlg
 
-
-instance (TransType f, TransType g) => TransType (f :+: g) where
-    transTypeAlg (Inl v) = transTypeAlg v
-    transTypeAlg (Inr v) = transTypeAlg v
+$(derive [liftSum] [''TransType])
 
 instance TransType ValueT where
     transTypeAlg TInt = VTInt
diff --git a/benchmark/Functions/Comp/Desugar.hs b/benchmark/Functions/Comp/Desugar.hs
--- a/benchmark/Functions/Comp/Desugar.hs
+++ b/benchmark/Functions/Comp/Desugar.hs
@@ -12,7 +12,7 @@
 
 import DataTypes.Comp
 import Data.Comp
-import Data.Traversable
+import Data.Comp.Derive
 
 -- de-sugar
 
@@ -22,14 +22,19 @@
 desugExpr :: SugarExpr -> Expr
 desugExpr = desug
 
+desugExpr' :: SugarExpr -> Expr
+desugExpr' = desug'
+
 desug :: Desug f e => Term f -> Term e
 {-# INLINE desug #-}
 desug = appTermHom desugAlg
 
-instance (Desug f e, Desug g e) => Desug (g :+: f) e where
-    desugAlg (Inl v) = desugAlg v
-    desugAlg (Inr v) = desugAlg v
+desug' :: Desug f e => Term f -> Term e
+{-# INLINE desug' #-}
+desug' = appTermHom' desugAlg
 
+$(derive [liftSum] [''Desug])
+
 instance (Value :<: v, Functor v) => Desug Value v where
     desugAlg = liftCxt
 
@@ -55,9 +60,7 @@
 desug2 :: (Functor f, Desug2 f g) => Term f -> Term g
 desug2 = cata desugAlg2
 
-instance (Desug2 f e, Desug2 g e) => Desug2 (f :+: g) e where
-    desugAlg2 (Inl v) = desugAlg2 v
-    desugAlg2 (Inr v) = desugAlg2 v
+$(derive [liftSum] [''Desug2])
 
 instance (Value :<: v) => Desug2 Value v where
     desugAlg2 = inject
diff --git a/benchmark/Functions/Comp/Eval.hs b/benchmark/Functions/Comp/Eval.hs
--- a/benchmark/Functions/Comp/Eval.hs
+++ b/benchmark/Functions/Comp/Eval.hs
@@ -13,6 +13,7 @@
 import DataTypes.Comp
 import Functions.Comp.Desugar
 import Data.Comp
+import Data.Comp.Derive
 import Control.Monad
 import Data.Traversable
 
@@ -24,9 +25,7 @@
 eval :: (Traversable e, Eval e v m) => Term e -> m (Term v)
 eval = cataM evalAlg
 
-instance (Eval f v m, Eval g v m) => Eval (f :+: g) v m where
-    evalAlg (Inl v) = evalAlg v
-    evalAlg (Inr v) = evalAlg v
+$(derive [liftSum] [''Eval])
 
 instance (Value :<: v, Monad m) => Eval Value v m where
     evalAlg = return . inject
@@ -79,9 +78,7 @@
 evalDirectE :: SugarExpr -> Err ValueExpr
 evalDirectE = evalDirect
 
-instance (EvalDir f m, EvalDir g m) => EvalDir (f :+: g) m where
-    evalDir (Inl v) = evalDir v
-    evalDir (Inr v) = evalDir v
+$(derive [liftSum] [''EvalDir])
 
 instance (Monad m) => EvalDir Value m where
     evalDir (VInt i) = return $ iVInt i
@@ -141,9 +138,7 @@
 eval2 :: (Functor e, Eval2 e v) => Term e -> Term v
 eval2 = cata eval2Alg
 
-instance (Eval2 f v, Eval2 g v) => Eval2 (f :+: g) v where
-    eval2Alg (Inl v) = eval2Alg v
-    eval2Alg (Inr v) = eval2Alg v
+$(derive [liftSum] [''Eval2])
 
 instance (Value :<: v) => Eval2 Value v where
     eval2Alg = inject
@@ -163,11 +158,6 @@
                 Just (VPair x y) -> (x,y)
                 _ -> undefined
 
-coerceLam2 :: (Lam :<: v) => Term v -> Term v -> Term v
-coerceLam2 t = case project t of
-                Just (Lam f) -> f
-                _ -> undefined
-
 instance (Value :<: v, EqF v) => Eval2 Op v where
     eval2Alg (Plus x y) = (\ i j -> iVInt (i + j)) (coerceInt2 x) (coerceInt2 y)
     eval2Alg (Mult x y) = (\ i j -> iVInt (i * j)) (coerceInt2 x) (coerceInt2 y)
@@ -202,9 +192,7 @@
 evalDirectE2 :: SugarExpr -> ValueExpr
 evalDirectE2 = evalDirect2
 
-instance (EvalDir2 f, EvalDir2 g) => EvalDir2 (f :+: g) where
-    evalDir2 (Inl v) = evalDir2 v
-    evalDir2 (Inr v) = evalDir2 v
+$(derive [liftSum] [''EvalDir2])
 
 instance EvalDir2 Value where
     evalDir2 (VInt i) = iVInt i
diff --git a/benchmark/Functions/Comp/Inference.hs b/benchmark/Functions/Comp/Inference.hs
--- a/benchmark/Functions/Comp/Inference.hs
+++ b/benchmark/Functions/Comp/Inference.hs
@@ -13,7 +13,7 @@
 import Functions.Comp.Desugar
 import DataTypes.Comp
 import Data.Comp
-import Data.Traversable
+import Data.Comp.Derive
 
 -- type inference
 
@@ -26,9 +26,7 @@
 inferBaseType :: (Traversable f, InferType f ValueT m) => Term f -> m BaseType
 inferBaseType = inferType
 
-instance (InferType f t m, InferType g t m) => InferType (f :+: g) t m where
-    inferTypeAlg (Inl v) = inferTypeAlg v
-    inferTypeAlg (Inr v) = inferTypeAlg v
+$(derive [liftSum] [''InferType])
 
 instance (ValueT :<: t, Monad m) => InferType Value t m where
     inferTypeAlg (VInt _) = return $ inject TInt
@@ -89,9 +87,7 @@
 inferBaseType2 :: (Functor f, InferType2 f ValueT) => Term f -> BaseType
 inferBaseType2 = inferType2
 
-instance (InferType2 f t, InferType2 g t) => InferType2 (f :+: g) t where
-    inferTypeAlg2 (Inl v) = inferTypeAlg2 v
-    inferTypeAlg2 (Inr v) = inferTypeAlg2 v
+$(derive [liftSum] [''InferType2])
 
 instance (ValueT :<: t) => InferType2 Value t where
     inferTypeAlg2 (VInt _) = inject TInt
diff --git a/benchmark/Functions/Standard/Desugar.hs b/benchmark/Functions/Standard/Desugar.hs
--- a/benchmark/Functions/Standard/Desugar.hs
+++ b/benchmark/Functions/Standard/Desugar.hs
@@ -21,3 +21,22 @@
 desug (PGt x y) = (desug y) `OLt` (desug x)
 desug (POr x y) = ONot (ONot (desug x) `OAnd` ONot (desug y))
 desug (PImpl x y) = ONot ((desug x) `OAnd` ONot (desug y))
+
+
+desug' :: PExpr -> PExpr
+desug' e@(PInt _) = e
+desug' e@(PBool _) = e
+desug' (PPair x y) = PPair (desug' x) (desug' y)
+desug' (PPlus x y) = PPlus (desug' x) (desug' y)
+desug' (PMult x y) = PMult (desug' x) (desug' y)
+desug' (PIf b x y) = PIf (desug' b) (desug' x) (desug' y)
+desug' (PEq x y) = PEq (desug' x) (desug' y)
+desug' (PLt x y) = PLt (desug' x) (desug' y)
+desug' (PAnd x y) = PAnd (desug' x) (desug' y)
+desug' (PNot x) = PNot (desug' x)
+desug' (PProj p x) = PProj p (desug' x)
+desug' (PNeg x) = PInt (-1) `PMult` (desug' x)
+desug' (PMinus x y) = (desug' x) `PPlus` ((PInt (-1)) `PMult` (desug' y))
+desug' (PGt x y) = (desug' y) `PLt` (desug' x)
+desug' (POr x y) = PNot (PNot (desug' x) `PAnd` PNot (desug' y))
+desug' (PImpl x y) = PNot ((desug' x) `PAnd` PNot (desug' y))
diff --git a/benchmark/Functions/Standard/Eval.hs b/benchmark/Functions/Standard/Eval.hs
--- a/benchmark/Functions/Standard/Eval.hs
+++ b/benchmark/Functions/Standard/Eval.hs
@@ -109,41 +109,3 @@
 
 desugEval2 :: PExpr -> SExpr
 desugEval2 = eval2 . desug
-
-
-
-
-coerceHOASInt2 :: HOASSExpr -> Int
-coerceHOASInt2 (HOASSInt i) = i
-coerceHOASInt2 _ = undefined
-
-coerceHOASBool2 :: HOASSExpr -> Bool
-coerceHOASBool2 (HOASSBool b) = b
-coerceHOASBool2 _ = undefined
-
-coerceHOASPair2 :: HOASSExpr -> (HOASSExpr,HOASSExpr)
-coerceHOASPair2 (HOASSPair x y) = (x,y)
-coerceHOASPair2 _ = undefined
-
-coerceHOASLam2 :: HOASSExpr -> HOASSExpr -> HOASSExpr
-coerceHOASLam2 (HOASSLam f) = f
-coerceHOASLam2 _ = undefined
-
-evalHOAS :: HOASExpr -> HOASSExpr
-evalHOAS (HOASInt i) = HOASSInt i
-evalHOAS (HOASBool b) = HOASSBool b
-evalHOAS (HOASPair x y) = HOASSPair (evalHOAS x) (evalHOAS y)
-evalHOAS (HOASPlus x y) = (\ x y -> HOASSInt (x + y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)
-evalHOAS (HOASMult x y) = (\ x y -> HOASSInt (x * y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)
-evalHOAS (HOASIf b x y) = if coerceHOASBool2 $ evalHOAS b then evalHOAS x else evalHOAS y
-evalHOAS (HOASEq x y) = (\ x y -> HOASSBool (x == y)) (evalHOAS x) (evalHOAS y)
-evalHOAS (HOASLt x y) = (\ x y -> HOASSBool (x < y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)
-evalHOAS (HOASAnd x y) =(\ x y -> HOASSBool (x && y)) (coerceHOASBool2 $ evalHOAS x) (coerceHOASBool2 $ evalHOAS y)
-evalHOAS (HOASNot x) = (HOASSBool . not)(coerceHOASBool2 $ evalHOAS x)
-evalHOAS (HOASProj p x) = select (coerceHOASPair2 $ evalHOAS x)
-    where select (x,y) = case p of
-                           SProjLeft -> x
-                           SProjRight -> y
-evalHOAS (HOASApp x y) = (coerceHOASLam2 $ evalHOAS x) (evalHOAS y)
-evalHOAS (HOASLam f) = HOASSLam $ evalHOAS . f
-evalHOAS (HOASVal v) = v
diff --git a/benchmark/Multi/DataTypes/Comp.hs b/benchmark/Multi/DataTypes/Comp.hs
--- a/benchmark/Multi/DataTypes/Comp.hs
+++ b/benchmark/Multi/DataTypes/Comp.hs
@@ -50,7 +50,7 @@
     Impl :: e Bool -> e Bool -> Sugar e Bool
 
 $(derive
-  [instanceHFunctor, instanceHFoldable, instanceHTraversable, instanceHEqF, smartHConstructors]
+  [makeHFunctor, makeHFoldable, makeHTraversable, makeHEqF, smartHConstructors]
   [''ValueT, ''Value, ''Op, ''Sugar])
 
 
diff --git a/compdata.cabal b/compdata.cabal
--- a/compdata.cabal
+++ b/compdata.cabal
@@ -1,5 +1,5 @@
 Name:			compdata
-Version:		0.2
+Version:		0.3
 Synopsis:            	Compositional Data Types
 Description:
 
@@ -16,7 +16,7 @@
   well by leveraging Haskell's type class machinery.
   .
   Building on that foundation, this library provides additional
-  extensions and (run-time) optimisations which makes compositional data types
+  extensions and (run-time) optimisations which make compositional data types
   usable for practical implementations. In particular, it
   provides an excellent framework for manipulating and analysing
   abstract syntax trees in a type-safe manner. Thus, it is perfectly
@@ -28,7 +28,7 @@
   *  Compositional data types in the style of Wouter Swierstra's
      Functional Pearl /Data types à la carte/.
   .
-  *  Modular definition of function on compositional data types through
+  *  Modular definition of functions on compositional data types through
      catamorphisms and anamorphisms as well as more structured
      recursion schemes such as primitive recursion  and co-recursion,
      and course-of-value iteration and co-iteration.
@@ -61,12 +61,25 @@
      also /smart constructors/, which allow to easily construct inhabitants
      of compositional data types, are automatically generated.
   .
-  *  /Mutually recursive data types/. All of the above is also lifted to
-     families of mutually recursive data types.
+  *  /Mutually recursive data types/ and
+     /generalised algebraic data types (GADTs)/. All of the above is also lifted
+     to families of mutually recursive data types and (more generally) GADTs.
+     This extension resides in the module "Data.Comp.Multi".
   .
-  For examples illustrating the use of compositional data types, consult
-  "Data.Comp" resp. "Data.Comp.Multi" for mutually recursive data types.
+  *  /Parametric compositional data types/. All of the above is also lifted
+     to parametric data types, which enables support for parametric higher-order
+     abstract syntax (PHOAS). This extension resides in the module
+     "Data.Comp.Param".
+  .
+  *  /Generalised parametric compositional data types/. All of the above is also
+     lifted to generalised parametric data types, which enables support for
+     typed parametric higher-order abstract syntax (PHOAS). This extension
+     resides in the module "Data.Comp.MultiParam".
+  .
 
+  Examples of using (generalised) (parametric) compositional data types are
+  bundled with the package in the libray @examples@.
+
 Category:            	Generics
 License:		BSD3
 License-file:		LICENSE
@@ -80,6 +93,11 @@
   testsuite/tests/Data_Test.hs,
   testsuite/tests/Data/Comp_Test.hs,
   testsuite/tests/Data/Comp/Equality_Test.hs,
+  testsuite/tests/Data/Comp/Examples_Test.hs,
+  testsuite/tests/Data/Comp/Examples/Comp.hs,
+  testsuite/tests/Data/Comp/Examples/Multi.hs,
+  testsuite/tests/Data/Comp/Examples/Param.hs,
+  testsuite/tests/Data/Comp/Examples/MultiParam.hs,
   testsuite/tests/Test/Utils.hs
   -- benchmark files
   benchmark/Test.hs
@@ -103,7 +121,31 @@
   benchmark/Functions/Standard/FreeVars.hs
   benchmark/Functions/Standard/Inference.hs
   benchmark/Functions/Standard.hs
-
+  -- example files
+  examples/Examples/GTermHom.hs
+  examples/Examples/Eval.hs
+  examples/Examples/EvalM.hs
+  examples/Examples/DesugarEval.hs
+  examples/Examples/DesugarPos.hs
+  examples/Examples/Automata.hs,
+  examples/Examples/Multi/Eval.hs
+  examples/Examples/Multi/EvalI.hs
+  examples/Examples/Multi/EvalM.hs
+  examples/Examples/Multi/DesugarEval.hs
+  examples/Examples/Multi/DesugarPos.hs
+  examples/Examples/Param/Eval.hs
+  examples/Examples/Param/EvalM.hs
+  examples/Examples/Param/EvalAlgM.hs
+  examples/Examples/Param/DesugarEval.hs
+  examples/Examples/Param/DesugarPos.hs
+  examples/Examples/Param/Parsing.hs
+  examples/Examples/MultiParam/Eval.hs
+  examples/Examples/MultiParam/EvalI.hs
+  examples/Examples/MultiParam/EvalM.hs
+  examples/Examples/MultiParam/EvalAlgM.hs
+  examples/Examples/MultiParam/DesugarEval.hs
+  examples/Examples/MultiParam/DesugarPos.hs
+  examples/Examples/MultiParam/FOL.hs
 
 flag test
   description: Build test executable.
@@ -115,49 +157,137 @@
 
 
 library
-  Exposed-Modules:      Data.Comp, Data.Comp.Product, Data.Comp.Sum,
-                        Data.Comp.Term, Data.Comp.Algebra, Data.Comp.Equality,
-                        Data.Comp.Ordering, Data.Comp.DeepSeq, Data.Comp.Generic
-                        Data.Comp.TermRewriting, Data.Comp.Automata,
-                        Data.Comp.Arbitrary, Data.Comp.Show, Data.Comp.Variables,
-                        Data.Comp.Decompose, Data.Comp.Unification,
-                        Data.Comp.Derive, Data.Comp.Matching, Data.Comp.Multi,
-                        Data.Comp.Multi.Term, Data.Comp.Multi.Sum,
+  Exposed-Modules:      Data.Comp,
+                        Data.Comp.Annotation,
+                        Data.Comp.Sum,
+                        Data.Comp.Term,
+                        Data.Comp.Algebra,
+                        Data.Comp.Equality,
+                        Data.Comp.Ordering,
+                        Data.Comp.DeepSeq,
+                        Data.Comp.Generic
+                        Data.Comp.TermRewriting,
+                        Data.Comp.Arbitrary,
+                        Data.Comp.Show,
+                        Data.Comp.Variables,
+                        Data.Comp.Decompose,
+                        Data.Comp.Unification,
+                        Data.Comp.Derive,
+                        Data.Comp.Matching,
+                        Data.Comp.Desugar,
+
+                        Data.Comp.Multi,
+                        Data.Comp.Multi.Term,
+                        Data.Comp.Multi.Sum,
                         Data.Comp.Multi.Functor,
-                        Data.Comp.Multi.Foldable, Data.Comp.Multi.Traversable,
+                        Data.Comp.Multi.Foldable,
+                        Data.Comp.Multi.Traversable,
                         Data.Comp.Multi.Algebra,
-                        Data.Comp.Multi.Product, Data.Comp.Multi.Show,
-                        Data.Comp.Multi.Equality, Data.Comp.Multi.Variables,
-                        Data.Comp.Multi.Ops, Data.Comp.Ops
+                        Data.Comp.Multi.Annotation,
+                        Data.Comp.Multi.Show,
+                        Data.Comp.Multi.Equality,
+                        Data.Comp.Multi.Variables,
+                        Data.Comp.Multi.Ops,
+                        Data.Comp.Ops,
+                        Data.Comp.Multi.Derive
+                        Data.Comp.Multi.Generic,
+                        Data.Comp.Multi.Desugar,
 
-  Other-Modules:        Data.Comp.Derive.Utils, Data.Comp.Derive.Equality,
-                        Data.Comp.Derive.Ordering, Data.Comp.Derive.Arbitrary,
-                        Data.Comp.Derive.Show, Data.Comp.Derive.DeepSeq,
+                        Data.Comp.Param,
+                        Data.Comp.Param.Term,
+                        Data.Comp.Param.FreshM,
+                        Data.Comp.Param.Any,
+                        Data.Comp.Param.Sum,
+                        Data.Comp.Param.Difunctor,
+                        Data.Comp.Param.Ditraversable,
+                        Data.Comp.Param.Algebra,
+                        Data.Comp.Param.Annotation,
+                        Data.Comp.Param.Ops
+                        Data.Comp.Param.Equality
+                        Data.Comp.Param.Ordering
+                        Data.Comp.Param.Show
+                        Data.Comp.Param.Derive,
+                        Data.Comp.Param.Desugar
+
+                        Data.Comp.MultiParam,
+                        Data.Comp.MultiParam.Term,
+                        Data.Comp.MultiParam.FreshM,
+                        Data.Comp.MultiParam.Any,
+                        Data.Comp.MultiParam.Sum,
+                        Data.Comp.MultiParam.HDifunctor,
+                        Data.Comp.MultiParam.HDitraversable,
+                        Data.Comp.MultiParam.Algebra,
+                        Data.Comp.MultiParam.Annotation,
+                        Data.Comp.MultiParam.Ops
+                        Data.Comp.MultiParam.Equality
+                        Data.Comp.MultiParam.Ordering
+                        Data.Comp.MultiParam.Show
+                        Data.Comp.MultiParam.Derive,
+                        Data.Comp.MultiParam.Desugar
+
+  Other-Modules:        Data.Comp.Derive.Utils,
+                        Data.Comp.Derive.Equality,
+                        Data.Comp.Derive.Ordering,
+                        Data.Comp.Derive.Arbitrary,
+                        Data.Comp.Derive.Show,
+                        Data.Comp.Derive.DeepSeq,
                         Data.Comp.Derive.SmartConstructors,
+                        Data.Comp.Derive.SmartAConstructors,
+                        Data.Comp.Derive.LiftSum,
                         Data.Comp.Derive.Foldable,
                         Data.Comp.Derive.Traversable,
-                        Data.Comp.Derive.Multi.Functor,
-                        Data.Comp.Derive.Multi.Foldable,
-                        Data.Comp.Derive.Multi.Traversable,
-                        Data.Comp.Derive.Multi.Equality,
-                        Data.Comp.Derive.Multi.Show,
-                        Data.Comp.Derive.Multi.SmartConstructors
+                        Data.Comp.Derive.Injections,
+                        Data.Comp.Derive.Projections,
 
-  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, th-expand-syns
+                        Data.Comp.Multi.Derive.Functor,
+                        Data.Comp.Multi.Derive.Foldable,
+                        Data.Comp.Multi.Derive.Traversable,
+                        Data.Comp.Multi.Derive.Equality,
+                        Data.Comp.Multi.Derive.Show,
+                        Data.Comp.Multi.Derive.SmartConstructors
+                        Data.Comp.Multi.Derive.SmartAConstructors
+                        Data.Comp.Multi.Derive.LiftSum,
+                        Data.Comp.Multi.Derive.Injections,
+                        Data.Comp.Multi.Derive.Projections,
+
+                        Data.Comp.Param.Derive.Difunctor,
+                        Data.Comp.Param.Derive.Ditraversable,
+                        Data.Comp.Param.Derive.Equality,
+                        Data.Comp.Param.Derive.Ordering,
+                        Data.Comp.Param.Derive.Show,
+                        Data.Comp.Param.Derive.SmartConstructors,
+                        Data.Comp.Param.Derive.SmartAConstructors,
+                        Data.Comp.Param.Derive.LiftSum,
+                        Data.Comp.Param.Derive.Injections,
+                        Data.Comp.Param.Derive.Projections,
+
+                        Data.Comp.MultiParam.Derive.HDifunctor,
+                        Data.Comp.MultiParam.Derive.Equality,
+                        Data.Comp.MultiParam.Derive.Ordering,
+                        Data.Comp.MultiParam.Derive.Show,
+                        Data.Comp.MultiParam.Derive.SmartConstructors,
+                        Data.Comp.MultiParam.Derive.SmartAConstructors,
+                        Data.Comp.MultiParam.Derive.LiftSum,
+                        Data.Comp.MultiParam.Derive.Injections,
+                        Data.Comp.MultiParam.Derive.Projections
+
+  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, th-expand-syns, transformers
   hs-source-dirs:	src
   ghc-options:          -W
+  if flag(benchmark)
+    buildable:     False
 
 Executable test
   Main-is:		Data_Test.hs
-  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2, derive, th-expand-syns, deepseq
-  hs-source-dirs:	src testsuite/tests
+  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2, derive, th-expand-syns, deepseq, transformers
+  hs-source-dirs:	src testsuite/tests examples
   ghc-options:          -fhpc
   if !flag(test)
     buildable:     False
 
 Executable benchmark
   Main-is:		Benchmark.hs
-  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns
+  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers
   hs-source-dirs:	src benchmark
   ghc-options:          -W -O2
   -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.
diff --git a/examples/Examples/Automata.hs b/examples/Examples/Automata.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Automata.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE RankNTypes #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Automata
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines tree automata based on compositional data types.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Automata where
+
+import Data.Comp
+import Data.Maybe
+import Data.Traversable
+import Control.Monad
+
+
+{-| This type represents transition functions of deterministic
+bottom-up tree acceptors (DUTAs).  -}
+
+type DUTATrans f q = Alg f q
+
+{-| This data type represents deterministic bottom-up tree acceptors (DUTAs).
+-}
+data DUTA f q = DUTA {
+      dutaTrans :: DUTATrans f q,
+      dutaAccept :: q -> Bool
+    }
+
+{-| This function runs the transition function of a DUTA on the given
+term. -}
+
+runDUTATrans :: Functor f => DUTATrans f q -> Term f -> q
+runDUTATrans = cata
+
+{-| This function checks whether a given DUTA accepts a term.  -}
+
+duta :: Functor f => DUTA f q -> Term f -> Bool
+duta DUTA{dutaTrans = trans, dutaAccept = accept} = accept . runDUTATrans trans
+
+
+
+{-| This type represents transition functions of non-deterministic
+bottom-up tree acceptors (NUTAs).  -}
+
+type NUTATrans f q = AlgM [] f q
+
+
+{-| This type represents non-deterministic bottom-up tree acceptors.
+-}
+data NUTA f q = NUTA {
+      nutaTrans :: AlgM [] f q,
+      nutaAccept :: q -> Bool
+    }
+
+{-| This function runs the given transition function of a NUTA on the
+given term -}
+
+runNUTATrans :: Traversable f => NUTATrans f q -> Term f -> [q]
+runNUTATrans = cataM
+
+{-| This function checks whether a given NUTA accepts a term. -}
+
+nuta :: Traversable f => NUTA f q -> Term f -> Bool
+nuta NUTA{nutaTrans = trans, nutaAccept = accept} = any accept . runNUTATrans trans
+
+
+{-| This function determinises the given NUTA.  -}
+
+determNUTA :: (Traversable f) => NUTA f q -> DUTA f [q]
+determNUTA n = DUTA{
+               dutaTrans = algM $ nutaTrans n,
+               dutaAccept = any $ nutaAccept n}
+
+{-| This function represents transition functions of
+deterministic bottom-up tree transducers (DUTTs).  -}
+
+type DUTTTrans f g q = forall a. f (q,a) -> (q, Cxt Hole g a)
+
+{-| This function transforms a DUTT transition function into an
+algebra.  -}
+
+duttTransAlg :: (Functor f, Functor g)  => DUTTTrans f g q -> Alg f (q, Term g)
+duttTransAlg trans = fmap injectCxt . trans 
+
+{-| This function runs the given DUTT transition function on the given
+term.  -}
+
+runDUTTTrans :: (Functor f, Functor g)  => DUTTTrans f g q -> Term f -> (q, Term g)
+runDUTTTrans = cata . duttTransAlg
+
+{-| This data type represents deterministic bottom-up tree
+transducers. -}
+
+data DUTT f g q = DUTT {
+      duttTrans :: DUTTTrans f g q,
+      duttAccept :: q -> Bool
+    }
+
+{-| This function transforms the given term according to the given
+DUTT and returns the resulting term provided it is accepted by the
+DUTT. -}
+
+dutt :: (Functor f, Functor g) => DUTT f g q -> Term f -> Maybe (Term g)
+dutt DUTT{duttTrans = trans, duttAccept = accept} = accept' . runDUTTTrans trans
+    where accept' (q,res)
+              | accept q = Just res
+              | otherwise = Nothing
+
+{-| This type represents transition functions of non-deterministic
+bottom-up tree transducers (NUTTs).  -}
+
+type NUTTTrans f g q = forall a. f (q,a) -> [(q, Cxt Hole g a)]
+
+{-| This function transforms a NUTT transition function into a monadic
+algebra.  -}
+
+nuttTransAlg :: (Functor f, Functor g)  => NUTTTrans f g q -> AlgM [] f (q, Term g)
+nuttTransAlg trans = liftM (fmap injectCxt) . trans 
+
+{-| This function runs the given NUTT transition function on the given
+term.  -}
+
+runNUTTTrans :: (Traversable f, Functor g)  => NUTTTrans f g q -> Term f -> [(q, Term g)]
+runNUTTTrans = cataM . nuttTransAlg
+
+{-| This data type represents non-deterministic bottom-up tree
+transducers (NUTTs). -}
+
+data NUTT f g q = NUTT {
+      nuttTrans :: NUTTTrans f g q,
+      nuttAccept :: q -> Bool
+    }
+
+{-| This function transforms the given term according to the given
+NUTT and returns a list containing all accepted results. -}
+
+nutt :: (Traversable f, Functor g) => NUTT f g q -> Term f -> [Term g]
+nutt NUTT{nuttTrans = trans, nuttAccept = accept} = mapMaybe accept' . runNUTTTrans trans
+    where accept' (q,res)
+              | accept q = Just res
+              | otherwise = Nothing
diff --git a/examples/Examples/DesugarEval.hs b/examples/Examples/DesugarEval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/DesugarEval.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.DesugarEval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Expression Evaluation
+--
+-- The example illustrates how to compose a term homomorphism and an algebra,
+-- exemplified via a desugaring term homomorphism and an evaluation algebra.
+--
+--------------------------------------------------------------------------------
+
+module Examples.DesugarEval where
+
+import Data.Comp
+import Data.Comp.Show ()
+import Data.Comp.Derive
+import Data.Comp.Desugar
+
+-- Signature for values, operators, and syntactic sugar
+data Value e = Const Int | Pair e e
+data Op e = Add e e | Mult e e | Fst e | Snd e
+data Sugar e = Neg e | Swap e
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Signature for the simple expression language, extended with syntactic sugar
+type Sig' = Sugar :+: Op :+: Value
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeFunctor, makeTraversable, makeFoldable,
+          makeEqF, makeShowF, smartConstructors]
+         [''Value, ''Op, ''Sugar])
+
+instance (Op :<: f, Value :<: f, Functor f) => Desugar Sugar f where
+  desugHom' (Neg x)  = iConst (-1) `iMult` x
+  desugHom' (Swap x) = iSnd x `iPair` iFst x
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+instance (Value :<: v) => Eval Value v where
+  evalAlg = inject
+
+instance (Value :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+  evalAlg (Fst x)    = fst $ projP x
+  evalAlg (Snd x)    = snd $ projP x
+
+projC :: (Value :<: v) => Term v -> Int
+projC v = case project v of Just (Const n) -> n
+
+projP :: (Value :<: v) => Term v -> (Term v, Term v)
+projP v = case project v of Just (Pair x y) -> (x,y)
+
+-- Compose the evaluation algebra and the desugaring homomorphism to an algebra
+eval :: Term Sig -> Term Value
+eval = cata evalAlg
+
+evalDesug :: Term Sig' -> Term Value
+evalDesug = eval . desugar
+
+-- Example: evalEx = iPair (iConst 2) (iConst 1)
+evalEx :: Term Value
+evalEx = evalDesug $ iSwap $ iPair (iConst 1) (iConst 2)
diff --git a/examples/Examples/DesugarPos.hs b/examples/Examples/DesugarPos.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/DesugarPos.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.DesugarPos
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Propagation of Annotations
+--
+-- The example illustrates how to lift a term homomorphism to products,
+-- exemplified via a desugaring term homomorphism lifted to terms annotated with
+-- source position information.
+--
+--------------------------------------------------------------------------------
+
+module Examples.DesugarPos where
+
+import Data.Comp
+import Data.Comp.Show ()
+import Data.Comp.Equality ()
+import Data.Comp.Derive
+import Data.Comp.Desugar
+
+-- Signature for values, operators, and syntactic sugar
+data Value e = Const Int | Pair e e
+data Op e = Add e e | Mult e e | Fst e | Snd e
+data Sugar e = Neg e | Swap e
+
+-- Source position information (line number, column number)
+data Pos = Pos Int Int
+           deriving (Show, Eq)
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+type SigP = Op :&: Pos :+: Value :&: Pos
+
+-- Signature for the simple expression language, extended with syntactic sugar
+type Sig' = Sugar :+: Op :+: Value
+type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeFunctor, makeTraversable, makeFoldable,
+          makeEqF, makeShowF, smartConstructors, smartAConstructors]
+         [''Value, ''Op, ''Sugar])
+
+instance (Op :<: f, Value :<: f, Functor f) => Desugar Sugar f where
+  desugHom' (Neg x)  = iConst (-1) `iMult` x
+  desugHom' (Swap x) = iSnd x `iPair` iFst x
+
+-- Example: desugEx = iPair (iConst 2) (iConst 1)
+desugEx :: Term Sig
+desugEx = desugar (iSwap $ iPair (iConst 1) (iConst 2) :: Term Sig')
+
+-- Lift desugaring to terms annotated with source positions
+desugP :: Term SigP' -> Term SigP
+desugP = appTermHom (propAnn desugHom)
+
+-- Example: desugPEx = iAPair (Pos 1 0)
+--                            (iASnd (Pos 1 0) (iAPair (Pos 1 1)
+--                                                     (iAConst (Pos 1 2) 1)
+--                                                     (iAConst (Pos 1 3) 2)))
+--                            (iAFst (Pos 1 0) (iAPair (Pos 1 1)
+--                                                     (iAConst (Pos 1 2) 1)
+--                                                     (iAConst (Pos 1 3) 2)))
+desugPEx :: Term SigP
+desugPEx = desugP $ iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1)
+                                                       (iAConst (Pos 1 3) 2))
diff --git a/examples/Examples/Eval.hs b/examples/Examples/Eval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Eval.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Eval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Expression Evaluation
+--
+-- The example illustrates how to use compositional data types to implement
+-- a small expression language, with a sub language of values, and an evaluation
+-- function mapping expressions to values.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Eval where
+
+import Data.Comp
+import Data.Comp.Show ()
+import Data.Comp.Derive
+
+-- Signature for values and operators
+data Value e = Const Int | Pair e e
+data Op e = Add e e | Mult e e | Fst e | Snd e
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeFunctor, makeShowF,
+          makeEqF, smartConstructors] [''Value, ''Op])
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+-- Lift the evaluation algebra to a catamorphism
+eval :: (Functor f, Eval f v) => Term f -> Term v
+eval = cata evalAlg
+
+instance (Value :<: v) => Eval Value v where
+  evalAlg = inject
+
+instance (Value :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+  evalAlg (Fst x)    = fst $ projP x
+  evalAlg (Snd x)    = snd $ projP x
+
+projC :: (Value :<: v) => Term v -> Int
+projC v = case project v of Just (Const n) -> n
+
+projP :: (Value :<: v) => Term v -> (Term v, Term v)
+projP v = case project v of Just (Pair x y) -> (x,y)
+
+-- Example: evalEx = iConst 5
+evalEx :: Term Value
+evalEx = eval ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
diff --git a/examples/Examples/EvalM.hs b/examples/Examples/EvalM.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/EvalM.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.EvalM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Monadic Expression Evaluation
+--
+-- The example illustrates how to use compositional data types to implement
+-- a small expression language, with a sub language of values, and a monadic
+-- evaluation function mapping expressions to values.
+--
+--------------------------------------------------------------------------------
+
+module Examples.EvalM where
+
+import Data.Comp
+import Data.Comp.Derive
+import Control.Monad (liftM)
+
+-- Signature for values and operators
+data Value e = Const Int | Pair e e
+data Op e = Add e e | Mult e e | Fst e | Snd e
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeFunctor, makeTraversable, makeFoldable,
+          makeEqF, makeShowF, smartConstructors]
+         [''Value, ''Op])
+
+-- Monadic term evaluation algebra
+class EvalM f v where
+  evalAlgM :: AlgM Maybe f (Term v)
+
+$(derive [liftSum] [''EvalM])
+
+-- Lift the monadic evaluation algebra to a monadic catamorphism
+evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v)
+evalM = cataM evalAlgM
+
+instance (Value :<: v) => EvalM Value v where
+  evalAlgM = return . inject
+
+instance (Value :<: v) => EvalM Op v where
+  evalAlgM (Add x y)  = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 + n2
+  evalAlgM (Mult x y) = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 * n2
+  evalAlgM (Fst v)    = liftM fst $ projP v
+  evalAlgM (Snd v)    = liftM snd $ projP v
+
+projC :: (Value :<: v) => Term v -> Maybe Int
+projC v = case project v of
+            Just (Const n) -> return n
+            _ -> Nothing
+
+projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)
+projP v = case project v of
+            Just (Pair x y) -> return (x,y)
+            _ -> Nothing
+
+-- Example: evalMEx = Just (iConst 5)
+evalMEx :: Maybe (Term Value)
+evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
diff --git a/examples/Examples/GTermHom.hs b/examples/Examples/GTermHom.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/GTermHom.hs
@@ -0,0 +1,230 @@
+{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances,
+  FlexibleContexts, UndecidableInstances, TemplateHaskell, TypeOperators,
+  ImplicitParams, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.GTermHom
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+--
+--------------------------------------------------------------------------------
+
+module Examples.GTermHom where
+
+import Data.Comp
+import Data.Comp.Show ()
+import Data.Map (Map)
+import Data.Maybe
+import qualified Data.Map as Map
+import Control.Monad
+import Data.Comp.Derive
+
+-- | An instance @a :< b@ means that @a@ is a component of @b@. @a@
+-- can be extracted from @b@ via the method 'ex'.
+class a :< b where
+    ex :: b -> a
+
+instance a :< a where
+    ex = id
+
+instance a :< (a,b) where
+    ex = fst
+
+instance (a :< b) => a :< (a',b) where
+    ex = ex . snd
+
+-- | This function provides access to components of the states from
+-- "below".
+below :: (?below :: a -> q, p :< q) => a -> p
+below = ex . ?below
+
+-- | This function provides access to components of the state from
+-- "above"
+above :: (?above :: q, p :< q) => p
+above = ex ?above
+
+-- | This type represents generalised term homomorphisms. Generalised
+-- term homomorphisms have access to a state that is provided
+-- (separately) by a DUTA or a DDTA (or both).
+type GTermHom q f g = forall a . (?below :: a -> q, ?above :: q) => f a -> Context g a
+
+class Functor f => Zippable f where
+    fzip :: f a -> [b] -> Maybe (f (a,b))
+    fzip = fzipWith (\ x y -> (x,y))
+    fzipWith :: (a -> b -> c) -> f a -> [b] -> Maybe (f c)
+    fzipWith f s l = fmap (fmap $ uncurry f) (fzip s l)
+
+-- | This type represents transition functions of deterministic
+-- bottom-up tree transducers (DUTTs).
+
+type UpTrans q f g = forall a. f (q,a) -> (q, Context g a)
+
+
+-- | This type represents transition functions of deterministic
+-- bottom-up tree acceptors (DUTAs).
+type UpState f q = Alg f q
+
+-- | This function combines the product DUTA of the two given DUTAs.
+prodUpState :: Functor f => UpState f p -> UpState f q -> UpState f (p,q)
+prodUpState sp sq t = (p,q) where
+    p = sp $ fmap fst t
+    q = sq $ fmap snd t
+
+-- | This function transforms DUTT transition function into an
+-- algebra.
+
+upAlg :: (Functor g)  => UpTrans q f g -> Alg f (q, Term g)
+upAlg trans = fmap appCxt . trans 
+
+-- | This function runs the given DUTT on the given term.
+
+runUpTrans :: (Functor f, Functor g) => UpTrans q f g -> Term f -> (q, Term g)
+runUpTrans = cata . upAlg
+
+-- | This function generalises 'runUpTrans' to contexts. Therefore,
+-- additionally, a transition function for the holes is needed.
+runUpTrans' :: (Functor f, Functor g) => UpTrans q f g -> (a -> q) -> Context f a -> (q, Context g a)
+runUpTrans' trans st = run where
+    run (Hole a) = (st a, Hole a)
+    run (Term t) = fmap appCxt $ trans $ fmap run t
+
+-- | This function composes two DUTTs.
+compUpTrans :: (Functor f, Functor g, Functor h)
+               => UpTrans q2 g h -> UpTrans q1 f g -> UpTrans (q1,q2) f h
+compUpTrans t2 t1 x = ((q1,q2), fmap snd c2) where
+    (q1, c1) = t1 $ fmap (\((q1,q2),a) -> (q1,(q2,a))) x
+    (q2, c2) = runUpTrans' t2 fst c1
+
+-- | This function turns constructs a DUTT from a given generalised
+-- term homomorphism with the state propagated by the given DUTA.
+toUpTrans :: (Functor f, Functor g) => UpState f q -> GTermHom q f g -> UpTrans q f g
+toUpTrans alg f t = (q, c)
+    where q = alg $ fmap fst t
+          c =  fmap snd $ (let ?below = fst; ?above = q in f t)
+
+-- | This function applies a given generalised term homomorphism with
+-- a state space propagated by the given DUTA to a term.
+upTermHom :: (Functor f, Functor g) => UpState f q -> GTermHom q f g -> Term f -> (q,Term g)
+upTermHom alg h = runUpTrans (toUpTrans alg h)
+
+-- | This function generalised 'upTermHom' to contexts. To this end
+-- also a transition function for holes is required.
+upTermHom' :: (Functor f, Functor g) => UpState f q -> GTermHom q f g -> (a -> q) -> Context f a -> (q, Context g a)
+upTermHom' alg h = runUpTrans' (toUpTrans alg h)
+
+
+-- | This type represents transition functions of deterministic
+-- top-down tree transducers (DDTTs).
+
+type DownTrans q f g = forall a. (q, f a) -> Context g (q,a)
+
+-- | This function runs the given DDTT on the given tree.
+runDownTrans :: (Functor f, Functor g) => DownTrans q f g -> q -> Cxt h f a -> Cxt h g a
+runDownTrans tr q t = run (q,t) where
+    run (q,Term t) = appCxt $ fmap run $  tr (q, t)
+    run (_,Hole a)      = Hole a
+
+-- | This function runs the given DDTT on the given tree.
+runDownTrans' :: (Functor f, Functor g) => DownTrans q f g -> q -> Cxt h f a -> Cxt h g (q,a)
+runDownTrans' tr q t = run (q,t) where
+    run (q,Term t) = appCxt $ fmap run $  tr (q, t)
+    run (q,Hole a)      = Hole (q,a)
+
+-- | This function composes two DDTTs.
+compDownTrans :: (Functor f, Functor g, Functor h)
+              => DownTrans p g h -> DownTrans q f g -> DownTrans (q,p) f h
+compDownTrans t2 t1 ((q,p), t) = fmap (\(p, (q, a)) -> ((q,p),a)) $ runDownTrans' t2 p (t1 (q, t))
+
+
+-- | This type represents transition functions of deterministic
+-- top-down tree acceptors (DDTAs).
+type DownState f q = forall a. Ord a => (q, f a) -> Map a q
+
+-- | This type is needed to construct the product of two DDTAs.
+data ProdState p q = LState p
+                   | RState q
+                   | BState p q
+
+-- | This function constructs the product DDTA of the given two DDTAs.
+prodDownState :: DownState f p -> DownState f q -> DownState f (p,q)
+prodDownState sp sq ((p,q),t) = Map.map final $ Map.unionWith combine ps qs
+    where ps = Map.map LState $ sp (p, t)
+          qs = Map.map RState $ sq (q, t)
+          combine (LState p) (RState q) = BState p q
+          combine (RState q) (LState p) = BState p q
+          combine _ _                   = error "unexpected merging"
+          final (LState p) = (p, q)
+          final (RState q) = (p, q)
+          final (BState p q) = (p,q)
+
+-- | This type is used for applying a DDTAs.
+newtype Numbered a = Numbered (a, Int)
+
+instance Eq (Numbered a) where
+    Numbered (_,i) == Numbered (_,j) = i == j
+
+instance Ord (Numbered a) where
+    compare (Numbered (_,i))  (Numbered (_,j)) = i `compare` j
+
+-- | This function constructs a DDTT from a given generalised term
+-- homomorphism with the state propagated by the given DDTA.
+toDownTrans :: Zippable f => DownState f q -> GTermHom q f g -> DownTrans q f g
+toDownTrans st f (q, s) = c
+    where s' = fromJust $ fzipWith (curry Numbered) s [0 ..]
+          qmap = st (q,s')
+          qfun = \ k@(Numbered (a,_)) -> (Map.findWithDefault q k qmap ,a)
+          s'' = fmap qfun s'
+          c   = (let ?above = q; ?below = fst in f) s''
+
+
+-- | This function applies a given generalised term homomorphism with
+-- a state space propagated by the given DUTA to a term.
+downTermHom :: (Zippable f, Functor g)
+            => DownState f q -> GTermHom q f g -> q -> Term f -> Term g
+downTermHom st h = runDownTrans (toDownTrans st h)
+
+
+-------------
+-- Example --
+-------------
+
+data Str a = Str
+data Base a = Char | List a
+
+type Typ = Str :+: Base
+
+$(derive [makeFunctor,smartConstructors, makeShowF] [''Str,''Base])
+
+class StringType f g where
+    strTypeHom :: (Bool :< q) => GTermHom q f g
+
+$(derive [liftSum] [''StringType])
+
+strType :: (Base :<: f, Functor f, Functor g, StringType f g)
+        => Term f -> Term g
+strType = snd . upTermHom isCharAlg strTypeHom
+
+isCharAlg :: (Base :<: f) => Alg f Bool
+isCharAlg t = case proj t of
+                Just Char -> True
+                _ -> False
+    
+instance (Str :<: f, Functor f) =>  StringType Str f where
+    strTypeHom = simpCxt . inj
+
+instance (Str :<:  f, Base :<: f, Functor f) =>  StringType Base f where
+    strTypeHom Char = iChar
+    strTypeHom (List t)
+               | below t  = iStr 
+               | otherwise = iList $ Hole t
+
+
+ex1 :: Term Typ
+ex1 = iList iChar
+
+runEx1 :: Term Typ
+runEx1 = strType ex1
diff --git a/examples/Examples/Multi/DesugarEval.hs b/examples/Examples/Multi/DesugarEval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Multi/DesugarEval.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
+  OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Multi.DesugarEval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Expression Evaluation
+--
+-- The example illustrates how to compose a term homomorphism and an algebra,
+-- exemplified via a desugaring term homomorphism and an evaluation algebra.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Multi.DesugarEval where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Show ()
+import Data.Comp.Multi.Derive
+import Data.Comp.Multi.Desugar
+
+-- Signature for values, operators, and syntactic sugar
+data Value e l where
+  Const  ::        Int -> Value e Int
+  Pair   :: e s -> e t -> Value e (s,t)
+data Op e l where
+  Add, Mult  :: e Int -> e Int   -> Op e Int
+  Fst        ::          e (s,t) -> Op e s
+  Snd        ::          e (s,t) -> Op e t
+data Sugar e l where
+  Neg   :: e Int   -> Sugar e Int
+  Swap  :: e (s,t) -> Sugar e (t,s)
+
+-- Source position information (line number, column number)
+data Pos = Pos Int Int
+           deriving Show
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+type SigP = Op :&: Pos :+: Value :&: Pos
+
+-- Signature for the simple expression language, extended with syntactic sugar
+type Sig' = Sugar :+: Op :+: Value
+type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
+
+-- Derive boilerplate code using Template Haskell (GHC 7 needed)
+$(derive [makeHFunctor, makeHTraversable, makeHFoldable,
+          makeHEqF, makeHShowF, smartConstructors]
+         [''Value, ''Op, ''Sugar])
+
+instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where
+  desugHom' (Neg x)  = iConst (-1) `iMult` x
+  desugHom' (Swap x) = iSnd x `iPair` iFst x
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+instance (Value :<: v) => Eval Value v where
+  evalAlg = inject
+
+instance (Value :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+  evalAlg (Fst x)    = fst $ projP x
+  evalAlg (Snd x)    = snd $ projP x
+
+projC :: (Value :<: v) => Term v Int -> Int
+projC v = case project v of Just (Const n) -> n
+
+projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t)
+projP v = case project v of Just (Pair x y) -> (x,y)
+
+-- Compose the evaluation algebra and the desugaring homomorphism to an
+-- algebra
+eval :: Term Sig' :-> Term Value
+eval = cata (evalAlg `compAlg` (desugHom :: TermHom Sig' Sig))
+
+-- Example: evalEx = iPair (iConst 2) (iConst 1)
+evalEx :: Term Value (Int,Int)
+evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)
diff --git a/examples/Examples/Multi/DesugarPos.hs b/examples/Examples/Multi/DesugarPos.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Multi/DesugarPos.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
+  OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Multi.DesugarPos
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Propagation of Annotations
+--
+-- The example illustrates how to lift a term homomorphism to products,
+-- exemplified via a desugaring term homomorphism lifted to terms annotated with
+-- source position information.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Multi.DesugarPos where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Show ()
+import Data.Comp.Multi.Derive
+import Data.Comp.Multi.Desugar
+
+-- Signature for values, operators, and syntactic sugar
+data Value e l where
+  Const  ::        Int -> Value e Int
+  Pair   :: e s -> e t -> Value e (s,t)
+data Op e l where
+  Add, Mult  :: e Int -> e Int   -> Op e Int
+  Fst        ::          e (s,t) -> Op e s
+  Snd        ::          e (s,t) -> Op e t
+data Sugar e l where
+  Neg   :: e Int   -> Sugar e Int
+  Swap  :: e (s,t) -> Sugar e (t,s)
+
+-- Source position information (line number, column number)
+data Pos = Pos Int Int
+           deriving (Show, Eq)
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+type SigP = Op :&: Pos :+: Value :&: Pos
+
+-- Signature for the simple expression language, extended with syntactic sugar
+type Sig' = Sugar :+: Op :+: Value
+type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
+
+-- Derive boilerplate code using Template Haskell (GHC 7 needed)
+$(derive [makeHFunctor, makeHTraversable, makeHFoldable,
+          makeHEqF, makeHShowF, smartConstructors, smartAConstructors]
+         [''Value, ''Op, ''Sugar])
+
+instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where
+  desugHom' (Neg x)  = iConst (-1) `iMult` x
+  desugHom' (Swap x) = iSnd x `iPair` iFst x
+
+-- Example: desugEx = iPair (iConst 2) (iConst 1)
+desugEx :: Term Sig (Int,Int)
+desugEx = desugar (iSwap $ iPair (iConst 1) (iConst 2) :: Term Sig' (Int,Int))
+
+-- Example: desugPEx = iAPair (Pos 1 0)
+--                            (iASnd (Pos 1 0) (iAPair (Pos 1 1)
+--                                                     (iAConst (Pos 1 2) 1)
+--                                                     (iAConst (Pos 1 3) 2)))
+--                            (iAFst (Pos 1 0) (iAPair (Pos 1 1)
+--                                                     (iAConst (Pos 1 2) 1)
+--                                                     (iAConst (Pos 1 3) 2)))
+desugPEx :: Term SigP (Int,Int)
+desugPEx = desugarA (iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1)
+                                                        (iAConst (Pos 1 3) 2))
+                     :: Term SigP' (Int,Int))
diff --git a/examples/Examples/Multi/Eval.hs b/examples/Examples/Multi/Eval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Multi/Eval.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Multi.Eval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Expression Evaluation
+--
+-- The example illustrates how to use generalised compositional data types 
+-- to implement a small expression language, with a sub language of values, and 
+-- an evaluation function mapping expressions to values.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Multi.Eval where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Show ()
+import Data.Comp.Multi.Derive
+
+-- Signature for values and operators
+data Value e l where
+  Const  ::        Int -> Value e Int
+  Pair   :: e s -> e t -> Value e (s,t)
+data Op e l where
+  Add, Mult  :: e Int -> e Int   -> Op e Int
+  Fst        ::          e (s,t) -> Op e s
+  Snd        ::          e (s,t) -> Op e t
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell (GHC 7 needed)
+$(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] 
+         [''Value, ''Op])
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+-- Lift the evaluation algebra to a catamorphism
+eval :: (HFunctor f, Eval f v) => Term f :-> Term v
+eval = cata evalAlg
+
+instance (Value :<: v) => Eval Value v where
+  evalAlg = inject
+
+instance (Value :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+  evalAlg (Fst x)    = fst $ projP x
+  evalAlg (Snd x)    = snd $ projP x
+
+projC :: (Value :<: v) => Term v Int -> Int
+projC v = case project v of Just (Const n) -> n
+
+projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t)
+projP v = case project v of Just (Pair x y) -> (x,y)
+
+-- Example: evalEx = iConst 2
+evalEx :: Term Value Int
+evalEx = eval (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int)
diff --git a/examples/Examples/Multi/EvalI.hs b/examples/Examples/Multi/EvalI.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Multi/EvalI.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Multi.EvalI
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Intrinsic Expression Evaluation
+--
+-- The example illustrates how to use generalised compositional data types 
+-- to implement a small expression language, and  an evaluation function mapping
+-- intrinsically typed expressions to values.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Multi.EvalI where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Show ()
+import Data.Comp.Multi.Derive
+
+-- Signature for values and operators
+data Value e l where
+  Const  ::        Int -> Value e Int
+  Pair   :: e s -> e t -> Value e (s,t)
+data Op e l where
+  Add, Mult  :: e Int -> e Int   -> Op e Int
+  Fst        ::          e (s,t) -> Op e s
+  Snd        ::          e (s,t) -> Op e t
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell (GHC 7 needed)
+$(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] 
+         [''Value, ''Op])
+
+-- Term evaluation algebra
+class EvalI f where
+  evalAlgI :: Alg f I
+
+$(derive [liftSum] [''EvalI])
+
+-- Lift the evaluation algebra to a catamorphism
+evalI :: (HFunctor f, EvalI f) => Term f i -> i
+evalI = unI . cata evalAlgI
+
+instance EvalI Value where
+  evalAlgI (Const n) = I n
+  evalAlgI (Pair (I x) (I y)) = I (x,y)
+
+instance EvalI Op where
+  evalAlgI (Add (I x) (I y))  = I (x + y)
+  evalAlgI (Mult (I x) (I y)) = I (x * y)
+  evalAlgI (Fst (I (x,_)))    = I x
+  evalAlgI (Snd (I (_,y)))    = I y
+
+-- Example: evalEx = 2
+evalIEx :: Int
+evalIEx = evalI (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int)
diff --git a/examples/Examples/Multi/EvalM.hs b/examples/Examples/Multi/EvalM.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Multi/EvalM.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Multi.EvalM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Monadic Expression Evaluation
+--
+-- The example illustrates how to use generalised compositional data types to
+-- implement a small expression language, with a sub language of values, and a 
+-- monadic evaluation function mapping expressions to values.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Multi.EvalM where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Show ()
+import Data.Comp.Multi.Derive
+import Control.Monad (liftM)
+
+-- Signature for values and operators
+data Value e l where
+  Const  ::        Int -> Value e Int
+  Pair   :: e s -> e t -> Value e (s,t)
+data Op e l where
+  Add, Mult  :: e Int -> e Int   -> Op e Int
+  Fst        ::          e (s,t) -> Op e s
+  Snd        ::          e (s,t) -> Op e t
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell (GHC 7 needed)
+$(derive [makeHFunctor, makeHTraversable, makeHFoldable,
+          makeHEqF, makeHShowF, smartConstructors]
+         [''Value, ''Op])
+
+-- Monadic term evaluation algebra
+class EvalM f v where
+  evalAlgM :: AlgM Maybe f (Term v)
+
+$(derive [liftSum] [''EvalM])
+
+evalM :: (HTraversable f, EvalM f v) => Term f l -> Maybe (Term v l)
+evalM = cataM evalAlgM
+
+instance (Value :<: v) => EvalM Value v where
+  evalAlgM = return . inject
+
+instance (Value :<: v) => EvalM Op v where
+  evalAlgM (Add x y)  = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 + n2
+  evalAlgM (Mult x y) = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 * n2
+  evalAlgM (Fst v)    = liftM fst $ projP v
+  evalAlgM (Snd v)    = liftM snd $ projP v
+
+projC :: (Value :<: v) => Term v Int -> Maybe Int
+projC v = case project v of
+            Just (Const n) -> return n; _ -> Nothing
+
+projP :: (Value :<: v) => Term v (a,b) -> Maybe (Term v a, Term v b)
+projP v = case project v of
+            Just (Pair x y) -> return (x,y); _ -> Nothing
+
+-- Example: evalMEx = Just (iConst 5)
+evalMEx :: Maybe (Term Value Int)
+evalMEx = evalM ((iConst 1) `iAdd`
+                 (iConst 2 `iMult` iConst 2) :: Term Sig Int)
diff --git a/examples/Examples/MultiParam/DesugarEval.hs b/examples/Examples/MultiParam/DesugarEval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/DesugarEval.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  TypeSynonymInstances, OverlappingInstances, GADTs, KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.DesugarEval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Expression Evaluation
+--
+-- The example illustrates how to compose a term homomorphism and an algebra,
+-- exemplified via a desugaring term homomorphism and an evaluation algebra.
+--
+-- The example extends the example from 'Examples.MultiParam.Eval'.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.DesugarEval where
+
+import Data.Comp.MultiParam hiding (Const)
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.Derive
+import Data.Comp.MultiParam.Desugar
+
+-- Signatures for values and operators
+data Const :: (* -> *) -> (* -> *) -> * -> * where
+    Const :: Int -> Const a e Int
+data Lam :: (* -> *) -> (* -> *) -> * -> * where
+    Lam :: (a i -> e j) -> Lam a e (i -> j)
+data App :: (* -> *) -> (* -> *) -> * -> * where
+    App :: e (i -> j) -> e i -> App a e j
+data Op :: (* -> *) -> (* -> *) -> * -> * where
+    Add :: e Int -> e Int -> Op a e Int
+    Mult :: e Int -> e Int -> Op a e Int
+data Fun :: (* -> *) -> (* -> *) -> * -> * where
+    Fun :: (e i -> e j) -> Fun a e (i -> j)
+data IfThenElse :: (* -> *) -> (* -> *) -> * -> * where
+                   IfThenElse :: (e Int) -> (e i) -> (e i) -> IfThenElse a e i
+
+-- Signature for syntactic sugar (negation, let expressions)
+data Sug :: (* -> *) -> (* -> *) -> * -> * where
+            Neg :: e Int -> Sug a e Int
+            Let :: e i -> (a i -> e j) -> Sug a e j
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op :+: IfThenElse
+-- Signature for the simple expression language with syntactic sugar
+type Sig' = Sug :+: Sig
+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)
+type Value = Const :+: Fun
+-- Signature for ground values.
+type GValue = Const
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op, ''IfThenElse, ''Sug])
+$(derive [makeHFoldable, makeHTraversable]
+         [''Const, ''App, ''Op])
+$(derive [smartConstructors] [''Fun])
+
+instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, HDifunctor f)
+  => Desugar Sug f where
+  desugHom' (Neg x)   = iConst (-1) `iMult` x
+  desugHom' (Let x y) = iLam y `iApp` x
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+-- Compose the evaluation algebra and the desugaring homomorphism to an algebra
+eval :: Term Sig' :-> Term Value
+eval = cata (evalAlg `compAlg` (desugHom :: TermHom Sig' Sig))
+
+instance (Const :<: v) => Eval Const v where
+  evalAlg (Const n) = iConst n
+
+instance (Const :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+
+instance (Fun :<: v) => Eval App v where
+  evalAlg (App x y) = (projF x) y
+
+instance (Fun :<: v) => Eval Lam v where
+  evalAlg (Lam f) = iFun f
+
+instance (Const :<: v) => Eval IfThenElse v where
+  evalAlg (IfThenElse c v1 v2) = if projC c /= 0 then v1 else v2
+
+projC :: (Const :<: v) => Term v Int -> Int
+projC v = case project v of Just (Const n) -> n
+
+projF :: (Fun :<: v) => Term v (i -> j) -> Term v i -> Term v j
+projF v = case project v of Just (Fun f) -> f
+
+-- |Evaluation of expressions to ground values.
+evalG :: Term Sig' i -> Maybe (Term GValue i)
+evalG = deepProject . (eval :: Term Sig' :-> Term Value)
+
+-- Example: evalEx = Just (iConst -6)
+evalEx :: Maybe (Term GValue Int)
+evalEx = evalG $ iLet (iConst 6) $ \x -> iNeg $ Place x
diff --git a/examples/Examples/MultiParam/DesugarPos.hs b/examples/Examples/MultiParam/DesugarPos.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/DesugarPos.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  TypeSynonymInstances, OverlappingInstances, GADTs, KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.DesugarPos
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Propagation of Annotations.
+--
+-- The example illustrates how to compose a term homomorphism and an algebra,
+-- exemplified via a desugaring term homomorphism and an evaluation algebra.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.DesugarPos where
+
+import Data.Comp.MultiParam hiding (Const)
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.Derive
+import Data.Comp.MultiParam.Desugar
+
+-- Signatures for values and operators
+data Const :: (* -> *) -> (* -> *) -> * -> * where
+    Const :: Int -> Const a e Int
+data Lam :: (* -> *) -> (* -> *) -> * -> * where
+    Lam :: (a i -> e j) -> Lam a e (i -> j)
+data App :: (* -> *) -> (* -> *) -> * -> * where
+    App :: e (i -> j) -> e i -> App a e j
+data Op :: (* -> *) -> (* -> *) -> * -> * where
+    Add :: e Int -> e Int -> Op a e Int
+    Mult :: e Int -> e Int -> Op a e Int
+data Fun :: (* -> *) -> (* -> *) -> * -> * where
+    Fun :: (e i -> e j) -> Fun a e (i -> j)
+data IfThenElse :: (* -> *) -> (* -> *) -> * -> * where
+                   IfThenElse :: (e Int) -> (e i) -> (e i) -> IfThenElse a e i
+
+-- Signature for syntactic sugar (negation, let expressions)
+data Sug :: (* -> *) -> (* -> *) -> * -> * where
+            Neg :: e Int -> Sug a e Int
+            Let :: e i -> (a i -> e j) -> Sug a e j
+
+-- Source position information (line number, column number)
+data Pos = Pos Int Int
+           deriving (Show, Eq)
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+type SigP = Const :&: Pos :+: Lam :&: Pos :+: App :&: Pos :+: Op :&: Pos
+
+-- Signature for the simple expression language, extended with syntactic sugar
+type Sig' = Sug :+: Sug
+type SigP' = Sug :&: Pos :+: SigP
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, makeEqHD, makeShowHD,
+          smartConstructors, smartAConstructors]
+         [''Const, ''Lam, ''App, ''Op, ''Sug])
+
+instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, HDifunctor f)
+  => Desugar Sug f where
+  desugHom' (Neg x)   = iConst (-1) `iMult` x
+  desugHom' (Let x y) = iLam y `iApp` x
+
+-- Example: desugPEx == iAApp (Pos 1 0)
+-- (iALam (Pos 1 0) $ \x -> iAMult (Pos 1 2) (iAConst (Pos 1 2) (-1)) (Place x))
+-- (iAConst (Pos 1 1) 6)
+desugPEx :: Term SigP Int
+desugPEx = desugarA (iALet (Pos 1 0)
+                           (iAConst (Pos 1 1) 6)
+                           (\x -> iANeg (Pos 1 2) $ Place x :: Term SigP' Int))
diff --git a/examples/Examples/MultiParam/Eval.hs b/examples/Examples/MultiParam/Eval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/Eval.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
+  KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.Eval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Expression Evaluation
+--
+-- The example illustrates how to use generalised parametric compositional data
+-- types to implement a small expression language, with a language of values,
+-- and an evaluation function mapping typed expressions to typed values. The
+-- example demonstrates how (parametric) abstractions are mapped to general
+-- functions, from values to values, and how it is possible to project a general
+-- value (with functions) back into ground values, that can again be analysed.
+--
+-- The following language extensions are needed in order to run the example:
+-- @TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
+-- @FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, @GADTs@,
+-- and @KindSignatures@.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.Eval where
+
+import Data.Comp.MultiParam hiding (Const)
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.Derive
+
+-- Signatures for values and operators
+data Const :: (* -> *) -> (* -> *) -> * -> * where
+    Const :: Int -> Const a e Int
+data Lam :: (* -> *) -> (* -> *) -> * -> * where
+    Lam :: (a i -> e j) -> Lam a e (i -> j)
+data App :: (* -> *) -> (* -> *) -> * -> * where
+    App :: e (i -> j) -> e i -> App a e j
+data Op :: (* -> *) -> (* -> *) -> * -> * where
+    Add :: e Int -> e Int -> Op a e Int
+    Mult :: e Int -> e Int -> Op a e Int
+data Fun :: (* -> *) -> (* -> *) -> * -> * where
+    Fun :: (e i -> e j) -> Fun a e (i -> j)
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)
+type Value = Const :+: Fun
+-- Signature for ground values.
+type GValue = Const
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op])
+$(derive [makeHFoldable, makeHTraversable]
+         [''Const, ''App, ''Op])
+$(derive [smartConstructors] [''Fun])
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+-- Lift the evaluation algebra to a catamorphism
+eval :: (HDifunctor f, Eval f v) => Term f :-> Term v
+eval = cata evalAlg
+
+instance (Const :<: v) => Eval Const v where
+  evalAlg (Const n) = iConst n
+
+instance (Const :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+
+instance (Fun :<: v) => Eval App v where
+  evalAlg (App x y) = (projF x) y
+
+instance (Fun :<: v) => Eval Lam v where
+  evalAlg (Lam f) = iFun f
+
+projC :: (Const :<: v) => Term v Int -> Int
+projC v = case project v of Just (Const n) -> n
+
+projF :: (Fun :<: v) => Term v (i -> j) -> Term v i -> Term v j
+projF v = case project v of Just (Fun f) -> f
+
+-- |Evaluation of expressions to ground values.
+evalG :: Term Sig i -> Maybe (Term GValue i)
+evalG = deepProject . (eval :: Term Sig :-> Term Value)
+
+-- Example: evalEx = Just (iConst 4)
+evalEx :: Maybe (Term GValue Int)
+evalEx = evalG $ (iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
diff --git a/examples/Examples/MultiParam/EvalAlgM.hs b/examples/Examples/MultiParam/EvalAlgM.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/EvalAlgM.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
+  KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.EvalAlgM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Monadic Expression Evaluation without PHOAS
+--
+-- The example illustrates how to use generalised parametric compositional
+-- data types to implement a small expression language, with a sub language of
+-- values, and a monadic evaluation function mapping expressions to values.
+-- The lack of PHOAS means that -- unlike the example in
+-- 'Examples.MultiParam.EvalM' -- a monadic algebra can be used.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.EvalAlgM where
+
+import Data.Comp.MultiParam
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.HDitraversable
+import Data.Comp.MultiParam.Derive
+import Control.Monad (liftM)
+
+-- Signature for values and operators
+data Value :: (* -> *) -> (* -> *) -> * -> * where
+              Const :: Int -> Value a e Int
+              Pair :: e i -> e j -> Value a e (i,j)
+data Op :: (* -> *) -> (* -> *) -> * -> * where
+           Add :: e Int -> e Int -> Op a e Int
+           Mult :: e Int -> e Int -> Op a e Int
+           Fst :: e (i,j) -> Op a e i
+           Snd :: e (i,j) -> Op a e j
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, makeHTraversable, makeHFoldable,
+          makeEqHD, makeShowHD, smartConstructors]
+         [''Value, ''Op])
+
+-- Monadic term evaluation algebra
+class EvalM f v where
+  evalAlgM :: AlgM Maybe f (Term v)
+
+$(derive [liftSum] [''EvalM])
+
+-- Lift the monadic evaluation algebra to a monadic catamorphism
+evalM :: (HDitraversable f Maybe (Term v), EvalM f v)
+         => Term f i -> Maybe (Term v i)
+evalM = cataM evalAlgM
+
+instance (Value :<: v) => EvalM Value v where
+  evalAlgM (Const n) = return $ iConst n
+  evalAlgM (Pair x y) = return $ iPair x y
+
+instance (Value :<: v) => EvalM Op v where
+  evalAlgM (Add x y)  = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 + n2
+  evalAlgM (Mult x y) = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 * n2
+  evalAlgM (Fst v)    = liftM fst $ projP v
+  evalAlgM (Snd v)    = liftM snd $ projP v
+
+projC :: (Value :<: v) => Term v Int -> Maybe Int
+projC v = case project v of
+            Just (Const n) -> return n
+            _ -> Nothing
+
+projP :: (Value :<: v) => Term v (i,j) -> Maybe (Term v i, Term v j)
+projP v = case project v of
+            Just (Pair x y) -> return (x,y)
+            _ -> Nothing
+
+-- Example: evalMEx = Just (iConst 5)
+evalMEx :: Maybe (Term Value Int)
+evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig Int)
diff --git a/examples/Examples/MultiParam/EvalI.hs b/examples/Examples/MultiParam/EvalI.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/EvalI.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
+  KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.EvalI
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Intrinsic Expression Evaluation
+--
+-- The example illustrates how to use generalised parametric compositional data
+-- types to implement a small expression language, and an evaluation function
+-- mapping typed expressions to values.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.EvalI where
+
+import Data.Comp.MultiParam hiding (Const)
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.Derive
+
+-- Signatures for values and operators
+data Const :: (* -> *) -> (* -> *) -> * -> * where
+    Const :: Int -> Const a e Int
+data Lam :: (* -> *) -> (* -> *) -> * -> * where
+    Lam :: (a i -> e j) -> Lam a e (i -> j)
+data App :: (* -> *) -> (* -> *) -> * -> * where
+    App :: e (i -> j) -> e i -> App a e j
+data Op :: (* -> *) -> (* -> *) -> * -> * where
+    Add :: e Int -> e Int -> Op a e Int
+    Mult :: e Int -> e Int -> Op a e Int
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op])
+$(derive [makeHFoldable, makeHTraversable]
+         [''Const, ''App, ''Op])
+
+-- Term evaluation algebra
+class Eval f where
+  evalAlg :: Alg f I
+  evalAlg = I . evalAlg'
+  evalAlg' :: f I I i -> i
+  evalAlg' = unI . evalAlg
+
+$(derive [liftSum] [''Eval])
+
+-- Lift the evaluation algebra to a catamorphism
+eval :: (HDifunctor f, Eval f) => Term f i -> i
+eval = unI . cata evalAlg
+
+instance Eval Const where
+  evalAlg' (Const n) = n
+
+instance Eval Op where
+  evalAlg' (Add (I x) (I y))  = x + y
+  evalAlg' (Mult (I x) (I y)) = x * y
+
+instance Eval App where
+  evalAlg' (App (I f) (I x)) = f x
+
+instance Eval Lam where
+  evalAlg' (Lam f) = unI . f . I
+
+-- Example: evalEx = 4
+evalEx :: Int
+evalEx = eval $ ((iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
+                 :: Term Sig Int)
diff --git a/examples/Examples/MultiParam/EvalM.hs b/examples/Examples/MultiParam/EvalM.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/EvalM.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,
+  KindSignatures, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.EvalM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Monadic Expression Evaluation
+--
+-- The example illustrates how to use generalised parametric compositional data
+-- types to implement a small expression language, with a language of values,
+-- and a monadic evaluation function mapping expressions to values. The example
+-- demonstrates how (parametric) abstractions are mapped to general functions,
+-- from values to /monadic/ values, and how it is possible to project a general
+-- value (with functions) back into ground values, that can again be analysed.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.EvalM where
+
+import Data.Comp.MultiParam hiding (Const)
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.Derive
+import Control.Monad ((<=<))
+
+-- Signatures for values and operators
+data Const :: (* -> *) -> (* -> *) -> * -> * where
+    Const :: Int -> Const a e Int
+data Lam :: (* -> *) -> (* -> *) -> * -> * where
+    Lam :: (a i -> e j) -> Lam a e (i -> j)
+data App :: (* -> *) -> (* -> *) -> * -> * where
+    App :: e (i -> j) -> e i -> App a e j
+data Op :: (* -> *) -> (* -> *) -> * -> * where
+    Add :: e Int -> e Int -> Op a e Int
+    Mult :: e Int -> e Int -> Op a e Int
+data FunM :: (* -> *) -> (* -> *) -> (* -> *) -> * -> * where
+    FunM :: (e i -> Compose m e j) -> FunM m a e (i -> j)
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+-- Signature for values. Note the use of 'FunM' rather than 'Lam' (!)
+type Value = Const :+: FunM Maybe
+-- Signature for ground values.
+type GValue = Const
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op])
+$(derive [makeHFoldable, makeHTraversable]
+         [''Const, ''App, ''Op])
+$(derive [smartConstructors] [''FunM])
+
+-- Term evaluation algebra.
+class EvalM f v where
+  evalAlgM :: AlgM' Maybe f (Term v)
+
+$(derive [liftSum] [''EvalM])
+
+-- Lift the evaluation algebra to a catamorphism
+evalM :: (HDifunctor f, EvalM f v) => Term f i -> Maybe (Term v i)
+evalM = cataM' evalAlgM
+
+instance (Const :<: v) => EvalM Const v where
+  evalAlgM (Const n) = return $ iConst n
+
+instance (Const :<: v) => EvalM Op v where
+  evalAlgM (Add mx my) = do x <- projC =<< getCompose mx
+                            y <- projC =<< getCompose my
+                            return $ iConst $ x + y
+  evalAlgM (Mult mx my) = do x <- projC =<< getCompose mx
+                             y <- projC =<< getCompose my
+                             return $ iConst $ x * y
+
+instance (FunM Maybe :<: v) => EvalM App v where
+  evalAlgM (App mx my) = do f <- projF =<< getCompose mx
+                            (getCompose . f) =<< getCompose my
+
+instance (FunM Maybe :<: v) => EvalM Lam v where
+  evalAlgM (Lam f) = return $ iFunM f
+
+projC :: (Const :<: v) => Term v Int -> Maybe Int
+projC v = case project v of
+            Just (Const n) -> return n; _ -> Nothing
+
+projF :: (FunM Maybe :<: v)
+         => Term v (i -> j) -> Maybe (Term v i -> Compose Maybe (Term v) j)
+projF v = case project v of
+            Just (FunM f :: FunM Maybe a (Term v) (i -> j)) -> return f
+            _ -> Nothing
+
+-- |Evaluation of expressions to ground values.
+evalMG :: Term Sig i -> Maybe (Term GValue i)
+evalMG = deepProject <=< (evalM :: Term Sig i -> Maybe (Term Value i))
+
+-- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12)
+evalMEx :: Maybe (Term GValue Int)
+evalMEx = evalMG $ (iLam $ \x -> iLam $ \y ->
+                                 Place y `iMult` (Place x `iAdd` Place x))
+                   `iApp` iConst 2 `iApp` iConst 3
diff --git a/examples/Examples/MultiParam/FOL.hs b/examples/Examples/MultiParam/FOL.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/MultiParam/FOL.hs
@@ -0,0 +1,452 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleInstances,
+  FlexibleContexts, UndecidableInstances, GADTs, KindSignatures,
+  OverlappingInstances, TypeSynonymInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.MultiParam.FOL
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- First-Order Logic à la Carte
+--
+-- This example illustrates how to implement First-Order Logic à la Carte
+-- (Knowles, The Monad.Reader Issue 11, '08) using Generalised Parametric
+-- Compositional Data Types.
+--
+-- Rather than having a fixed domain @Term@ for binders, a la Knowles, our
+-- encoding uses a mutually recursive data structure for terms and formulae.
+-- This enables variables to be introduced only when they are actually needed
+-- in the term language, i.e. in stage 5.
+--
+--------------------------------------------------------------------------------
+
+module Examples.MultiParam.FOL where
+
+import Data.Comp.MultiParam hiding (Const)
+import Data.Comp.MultiParam.Show ()
+import Data.Comp.MultiParam.Derive
+import Data.Comp.MultiParam.FreshM (genVar)
+import Data.List (intersperse)
+import Data.Maybe
+import Control.Monad.State
+import Control.Monad.Reader
+
+-- Phantom types indicating whether a (recursive) term is a formula or a term
+data TFormula
+data TTerm
+
+-- Terms
+data Const :: (* -> *) -> (* -> *) -> * -> * where
+              Const :: String -> [e TTerm] -> Const a e TTerm
+data Var :: (* -> *) -> (* -> *) -> * -> * where
+            Var :: String -> Var a e TTerm
+
+-- Formulae
+data TT :: (* -> *) -> (* -> *) -> * -> * where
+           TT :: TT a e TFormula
+data FF :: (* -> *) -> (* -> *) -> * -> * where
+           FF :: FF a e TFormula
+data Atom :: (* -> *) -> (* -> *) -> * -> * where
+             Atom :: String -> [e TTerm] -> Atom a e TFormula
+data NAtom :: (* -> *) -> (* -> *) -> * -> * where
+              NAtom :: String -> [e TTerm] -> NAtom a e TFormula
+data Not :: (* -> *) -> (* -> *) -> * -> * where
+            Not :: e TFormula -> Not a e TFormula
+data Or :: (* -> *) -> (* -> *) -> * -> * where
+           Or :: e TFormula -> e TFormula -> Or a e TFormula
+data And :: (* -> *) -> (* -> *) -> * -> * where
+            And :: e TFormula -> e TFormula -> And a e TFormula
+data Impl :: (* -> *) -> (* -> *) -> * -> * where
+             Impl :: e TFormula -> e TFormula -> Impl a e TFormula
+data Exists :: (* -> *) -> (* -> *) -> * -> * where
+               Exists :: (a TTerm -> e TFormula) -> Exists a e TFormula
+data Forall :: (* -> *) -> (* -> *) -> * -> * where
+               Forall :: (a TTerm -> e TFormula) -> Forall a e TFormula
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeHDifunctor, smartConstructors]
+         [''Const, ''Var, ''TT, ''FF, ''Atom, ''NAtom,
+          ''Not, ''Or, ''And, ''Impl, ''Exists, ''Forall])
+
+--------------------------------------------------------------------------------
+-- Pretty printing of terms and formulae
+--------------------------------------------------------------------------------
+
+instance ShowHD Const where
+    showHD (Const f t) = do
+      ts <- mapM pshow t
+      return $ f ++ "(" ++ concat (intersperse ", " ts) ++ ")"
+
+instance ShowHD Var where
+    showHD (Var x) = return x
+
+instance ShowHD TT where
+    showHD TT = return "true"
+
+instance ShowHD FF where
+    showHD FF = return "false"
+
+instance ShowHD Atom where
+    showHD (Atom p t) = do
+      ts <- mapM pshow t
+      return $ p ++ "(" ++ concat (intersperse ", " ts) ++ ")"
+
+instance ShowHD NAtom where
+    showHD (NAtom p t) = do
+      ts <- mapM pshow t
+      return $ "not " ++ p ++ "(" ++ concat (intersperse ", " ts) ++ ")"
+
+instance ShowHD Not where
+    showHD (Not f) = liftM (\x -> "not (" ++ x ++ ")") (pshow f)
+
+instance ShowHD Or where
+    showHD (Or f1 f2) =
+        liftM2 (\x y -> "(" ++ x ++ ") or (" ++ y ++ ")") (pshow f1) (pshow f2)
+
+instance ShowHD And where
+    showHD (And f1 f2) =
+        liftM2 (\x y -> "(" ++ x ++ ") and (" ++ y ++ ")") (pshow f1) (pshow f2)
+
+instance ShowHD Impl where
+    showHD (Impl f1 f2) =
+        liftM2 (\x y -> "(" ++ x ++ ") -> (" ++ y ++ ")") (pshow f1) (pshow f2)
+
+instance ShowHD Exists where
+    showHD (Exists f) = do x <- genVar
+                           x' <- pshow x
+                           b <- pshow $ f x
+                           return $ "exists " ++ x' ++ ". " ++ b
+
+instance ShowHD Forall where
+    showHD (Forall f) = do x <- genVar
+                           x' <- pshow x
+                           b <- pshow $ f x
+                           return $ "forall " ++ x' ++ ". " ++ b
+
+--------------------------------------------------------------------------------
+-- Stage 0
+--------------------------------------------------------------------------------
+
+type Input = Const :+: TT :+: FF :+: Atom :+: Not :+: Or :+: And :+:
+             Impl :+: Exists :+: Forall
+
+foodFact :: Term Input TFormula
+foodFact =
+    (iExists $ \p -> iAtom "Person" [Place p] `iAnd`
+                     (iForall $ \f -> iAtom "Food" [Place f] `iImpl`
+                                      iAtom "Eats" [Place p,Place f])) `iImpl`
+    iNot (iExists $ \f -> iAtom "Food" [Place f] `iAnd`
+                          iNot (iExists $ \p -> iAtom "Person" [Place p] `iAnd`
+                                                iAtom "Eats" [Place p,Place f]))
+
+--------------------------------------------------------------------------------
+-- Stage 1
+--------------------------------------------------------------------------------
+
+type Stage1 = Const :+: TT :+: FF :+: Atom :+: Not :+: Or :+: And :+:
+              Exists :+: Forall
+
+class ElimImp f where
+    elimImpHom :: TermHom f Stage1
+
+$(derive [liftSum] [''ElimImp])
+
+instance (f :<: Stage1) => ElimImp f where
+    elimImpHom = simpCxt . inj
+
+instance ElimImp Impl where
+    elimImpHom (Impl f1 f2) = iNot (Hole f1) `iOr` (Hole f2)
+
+elimImp :: Term Input :-> Term Stage1
+elimImp = appTermHom elimImpHom
+
+foodFact1 :: Term Stage1 TFormula
+foodFact1 = elimImp foodFact
+
+--------------------------------------------------------------------------------
+-- Stage 2
+--------------------------------------------------------------------------------
+
+type Stage2 = Const :+: TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+:
+              Exists :+: Forall
+
+class Dualize f where
+    dualizeHom :: TermHom f Stage2
+
+$(derive [liftSum] [''Dualize])
+
+instance Dualize Const where
+    dualizeHom (Const f t) = iConst f $ map Hole t
+
+instance Dualize TT where
+    dualizeHom TT = iFF
+
+instance Dualize FF where
+    dualizeHom FF = iTT
+
+instance Dualize Atom where
+    dualizeHom (Atom p t) = iNAtom p $ map Hole t
+
+instance Dualize NAtom where
+    dualizeHom (NAtom p t) = iAtom p $ map Hole t
+
+instance Dualize Or where
+    dualizeHom (Or f1 f2) = Hole f1 `iAnd` Hole f2
+
+instance Dualize And where
+    dualizeHom (And f1 f2) = Hole f1 `iOr` Hole f2
+
+instance Dualize Exists where
+    dualizeHom (Exists f) = iForall (Hole . f)
+
+instance Dualize Forall where
+    dualizeHom (Forall f) = iExists (Hole . f)
+
+dualize :: Term Stage2 :-> Term Stage2
+dualize = appTermHom dualizeHom
+
+class PushNot f where
+    pushNotAlg :: Alg f (Term Stage2)
+
+$(derive [liftSum] [''PushNot])
+
+instance PushNot Const where
+    pushNotAlg (Const f t) = iConst f t
+
+instance PushNot TT where
+    pushNotAlg TT = iTT
+
+instance PushNot FF where
+    pushNotAlg FF = iFF
+
+instance PushNot Atom where
+    pushNotAlg (Atom p t) = iAtom p t
+
+instance PushNot Not where
+    pushNotAlg (Not f) = dualize f
+
+instance PushNot Or where
+    pushNotAlg (Or f1 f2) = f1 `iOr` f2
+
+instance PushNot And where
+    pushNotAlg (And f1 f2) = f1 `iAnd` f2
+
+instance PushNot Exists where
+    pushNotAlg (Exists f) = iExists (f . Place)
+
+instance PushNot Forall where
+    pushNotAlg (Forall f) = iForall (f . Place)
+
+pushNotInwards :: Term Stage1 :-> Term Stage2
+pushNotInwards = cata pushNotAlg
+
+foodFact2 :: Term Stage2 TFormula
+foodFact2 = pushNotInwards foodFact1
+
+--------------------------------------------------------------------------------
+-- Stage 4
+--------------------------------------------------------------------------------
+
+type Stage4 = Const :+: TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+: Forall
+
+type Unique = Int
+data UniqueSupply = UniqueSupply Unique UniqueSupply UniqueSupply
+
+initialUniqueSupply :: UniqueSupply
+initialUniqueSupply = genSupply 1
+    where genSupply n = UniqueSupply n (genSupply (2 * n))
+                                       (genSupply (2 * n + 1))
+
+splitUniqueSupply :: UniqueSupply -> (UniqueSupply, UniqueSupply)
+splitUniqueSupply (UniqueSupply	_ l r) = (l,r)
+
+getUnique :: UniqueSupply -> (Unique, UniqueSupply)
+getUnique (UniqueSupply n l _) = (n,l)
+
+type Supply = State UniqueSupply
+type S = ReaderT [Term Stage4 TTerm] Supply
+
+evalS :: S a -> [Term Stage4 TTerm] -> UniqueSupply -> a
+evalS m env s = evalState (runReaderT m env) s
+
+fresh :: S Int
+fresh = do supply <- get
+           let (uniq,rest) = getUnique supply
+           put rest
+           return uniq
+
+freshes :: S UniqueSupply
+freshes = do supply <- get
+             let (l,r) = splitUniqueSupply supply
+             put r
+             return l
+
+class Skolem f where
+    skolemAlg :: AlgM' S f (Term Stage4)
+
+$(derive [liftSum] [''Skolem])
+
+instance Skolem Const where
+    skolemAlg (Const f t) = liftM (iConst f) $ mapM getCompose t
+
+instance Skolem TT where
+    skolemAlg TT = return iTT
+
+instance Skolem FF where
+    skolemAlg FF = return iFF
+
+instance Skolem Atom where
+    skolemAlg (Atom p t) = liftM (iAtom p) $ mapM getCompose t
+
+instance Skolem NAtom where
+    skolemAlg (NAtom p t) = liftM (iNAtom p) $ mapM getCompose t
+
+instance Skolem Or where
+    skolemAlg (Or f1 f2) = liftM2 iOr (getCompose f1) (getCompose f2)
+
+instance Skolem And where
+    skolemAlg (And f1 f2) = liftM2 iAnd (getCompose f1) (getCompose f2)
+
+instance Skolem Forall where
+    skolemAlg (Forall f) = do
+      supply <- freshes
+      xs <- ask
+      return $ iForall $ \x -> evalS (getCompose $ f (Place x))
+                                     (Place x : xs)
+                                     supply
+
+instance Skolem Exists where
+    skolemAlg (Exists f) = do uniq <- fresh
+                              xs <- ask
+                              getCompose $ f (iConst ("Skol" ++ show uniq) xs)
+
+skolemize :: Term Stage2 :-> Term Stage4
+skolemize f = evalState (runReaderT (cataM' skolemAlg f) []) initialUniqueSupply
+
+foodFact4 :: Term Stage4 TFormula
+foodFact4 = skolemize foodFact2
+
+--------------------------------------------------------------------------------
+-- Stage 5
+--------------------------------------------------------------------------------
+
+type Stage5 = Const :+: Var :+: TT :+: FF :+: Atom :+: NAtom :+: Or :+: And
+
+class Prenex f where
+    prenexAlg :: AlgM' S f (Term Stage5)
+
+$(derive [liftSum] [''Prenex])
+
+instance Prenex Const where
+    prenexAlg (Const f t) = liftM (iConst f) $ mapM getCompose t
+
+instance Prenex TT where
+    prenexAlg TT = return iTT
+
+instance Prenex FF where
+    prenexAlg FF = return iFF
+
+instance Prenex Atom where
+    prenexAlg (Atom p t) = liftM (iAtom p) $ mapM getCompose t
+
+instance Prenex NAtom where
+    prenexAlg (NAtom p t) = liftM (iNAtom p) $ mapM getCompose t
+
+instance Prenex Or where
+    prenexAlg (Or f1 f2) = liftM2 iOr (getCompose f1) (getCompose f2)
+
+instance Prenex And where
+    prenexAlg (And f1 f2) = liftM2 iAnd (getCompose f1) (getCompose f2)
+
+instance Prenex Forall where
+    prenexAlg (Forall f) = do uniq <- fresh
+                              getCompose $ f (iVar ("x" ++ show uniq))
+
+prenex :: Term Stage4 :-> Term Stage5
+prenex f = evalState (runReaderT (cataM' prenexAlg f) []) initialUniqueSupply
+
+foodFact5 :: Term Stage5 TFormula
+foodFact5 = prenex foodFact4
+
+--------------------------------------------------------------------------------
+-- Stage 6
+--------------------------------------------------------------------------------
+
+type Literal = Term (Const :+: Var :+: Atom :+: NAtom)
+newtype Clause i = Clause {unClause :: [Literal i]} -- implicit disjunction
+newtype CNF i = CNF {unCNF :: [Clause i]} -- implicit conjunction
+
+instance Show (Clause i) where
+    show c = concat $ intersperse " or " $ map show $ unClause c
+
+instance Show (CNF i) where
+    show c = concat $ intersperse "\n" $ map show $ unCNF c
+
+class ToCNF f where
+    cnfAlg :: Alg f CNF
+
+$(derive [liftSum] [''ToCNF])
+
+instance ToCNF Const where
+    cnfAlg (Const f t) = CNF [Clause [iConst f (map (head . unClause . head . unCNF) t)]]
+
+instance ToCNF Var where
+    cnfAlg (Var x) = CNF [Clause [iVar x]]
+
+instance ToCNF TT where
+    cnfAlg TT = CNF []
+
+instance ToCNF FF where
+    cnfAlg FF = CNF [Clause []]
+
+instance ToCNF Atom where
+    cnfAlg (Atom p t) = CNF [Clause [iAtom p (map (head . unClause . head . unCNF) t)]]
+
+instance ToCNF NAtom where
+    cnfAlg (NAtom p t) = CNF [Clause [iNAtom p (map (head . unClause . head . unCNF) t)]]
+
+instance ToCNF And where
+    cnfAlg (And f1 f2) = CNF $ unCNF f1 ++ unCNF f2
+
+instance ToCNF Or where
+    cnfAlg (Or f1 f2) = CNF [Clause (x ++ y) | Clause x <- unCNF f1, Clause y <- unCNF f2]
+
+cnf :: Term Stage5 :-> CNF
+cnf = cata cnfAlg
+
+foodFact6 :: CNF TFormula
+foodFact6 = cnf foodFact5
+
+--------------------------------------------------------------------------------
+-- Stage 7
+--------------------------------------------------------------------------------
+
+type T = Const :+: Var :+: Atom :+: NAtom
+newtype IClause i = IClause ([Term T i], -- implicit conjunction
+                             [Term T i]) -- implicit disjunction
+newtype INF i = INF [IClause i] -- implicit conjunction
+
+instance Show (IClause i) where
+    show (IClause (cs,ds)) =
+        let cs' = concat $ intersperse " and " $ map show cs
+            ds' = concat $ intersperse " or " $ map show ds
+        in "(" ++ cs' ++ ") -> (" ++ ds' ++ ")"
+
+instance Show (INF i) where
+    show (INF fs) = concat $ intersperse "\n" $ map show fs
+
+inf :: CNF TFormula -> INF TFormula
+inf (CNF f) = INF $ map (toImpl . unClause) f
+    where toImpl :: [Literal TFormula] -> IClause TFormula
+          toImpl disj = IClause ([iAtom p t | NAtom p t <- mapMaybe proj1 disj],
+                                 [inject t | t <- mapMaybe proj2 disj])
+          proj1 :: NatM Maybe (Term T) (NAtom Any (Term T))
+          proj1 = project
+          proj2 :: NatM Maybe (Term T) (Atom Any (Term T))
+          proj2 = project
+
+foodFact7 :: INF TFormula
+foodFact7 = inf foodFact6
diff --git a/examples/Examples/Param/DesugarEval.hs b/examples/Examples/Param/DesugarEval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Param/DesugarEval.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  TypeSynonymInstances, OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Param.DesugarEval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Expression Evaluation
+--
+-- The example illustrates how to compose a term homomorphism and an algebra,
+-- exemplified via a desugaring term homomorphism and an evaluation algebra.
+--
+-- The example extends the example from 'Examples.Param.Eval'.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Param.DesugarEval where
+
+import Data.Comp.Param hiding (Const)
+import Data.Comp.Param.Show ()
+import Data.Comp.Param.Derive
+import Data.Comp.Param.Desugar
+
+-- Signatures for values and operators
+data Const a e = Const Int
+data Lam a e = Lam (a -> e) -- Note: not e -> e
+data App a e = App e e
+data Op a e = Add e e | Mult e e
+data Fun a e = Fun (e -> e) -- Note: not a -> e
+data IfThenElse a e = IfThenElse e e e
+
+-- Signature for syntactic sugar (negation, let expressions, Y combinator)
+data Sug a e = Neg e | Let e (a -> e) | Fix
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op :+: IfThenElse
+-- Signature for the simple expression language with syntactic sugar
+type Sig' = Sug :+: Sig
+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)
+type Value = Const :+: Fun
+-- Signature for ground values.
+type GValue = Const
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeDifunctor, makeEqD, makeShowD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op, ''IfThenElse, ''Sug])
+$(derive [makeDitraversable]
+         [''Const, ''App, ''Op])
+$(derive [smartConstructors] [''Fun])
+
+instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, Difunctor f)
+  => Desugar Sug f where
+  desugHom' (Neg x)   = iConst (-1) `iMult` x
+  desugHom' (Let x y) = iLam y `iApp` x
+  desugHom' Fix       = iLam $ \f ->
+                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
+                           `iApp`
+                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+-- Compose the evaluation algebra and the desugaring homomorphism to an algebra
+eval :: Term Sig -> Term Value
+eval = cata evalAlg
+
+evalDesug :: Term Sig' -> Term Value
+evalDesug = eval . desugar
+
+instance (Const :<: v) => Eval Const v where
+  evalAlg (Const n) = iConst n
+
+instance (Const :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+
+instance (Fun :<: v) => Eval App v where
+  evalAlg (App x y) = (projF x) y
+
+instance (Fun :<: v) => Eval Lam v where
+  evalAlg (Lam f) = iFun f
+
+instance (Const :<: v) => Eval IfThenElse v where
+  evalAlg (IfThenElse c v1 v2) = if projC c /= 0 then v1 else v2
+
+projC :: (Const :<: v) => Term v -> Int
+projC v = case project v of Just (Const n) -> n
+
+projF :: (Fun :<: v) => Term v -> Term v -> Term v
+projF v = case project v of Just (Fun f) -> f
+
+-- |Evaluation of expressions to ground values.
+evalG :: Term Sig' -> Maybe (Term GValue)
+evalG = deepProject . evalDesug
+
+-- Example: evalEx = Just (iConst 720)
+evalEx :: Maybe (Term GValue)
+evalEx = evalG $ fact `iApp` iConst 6
+
+fact :: Term Sig'
+fact = iFix `iApp`
+       (iLam $ \f ->
+          iLam $ \n ->
+              iIfThenElse
+              (Place n)
+              (Place n `iMult` (Place f `iApp` (Place n `iAdd` iConst (-1))))
+              (iConst 1))
diff --git a/examples/Examples/Param/DesugarPos.hs b/examples/Examples/Param/DesugarPos.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Param/DesugarPos.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  TypeSynonymInstances, OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Param.DesugarPos
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Desugaring + Propagation of Annotations
+--
+-- The example illustrates how to compose a term homomorphism and an algebra,
+-- exemplified via a desugaring term homomorphism and an evaluation algebra.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Param.DesugarPos where
+
+import Data.Comp.Param hiding (Const)
+import Data.Comp.Param.Show ()
+import Data.Comp.Param.Derive
+import Data.Comp.Param.Desugar
+
+-- Signatures for values and operators
+data Const a e = Const Int
+data Lam a e = Lam (a -> e) -- Note: not e -> e
+data App a e = App e e
+data Op a e = Add e e | Mult e e
+
+-- Signature for syntactic sugar (negation, let expressions, Y combinator)
+data Sug a e = Neg e | Let e (a -> e) | Fix
+
+-- Source position information (line number, column number)
+data Pos = Pos Int Int
+           deriving (Show, Eq)
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+type SigP = Const :&: Pos :+: Lam :&: Pos :+: App :&: Pos :+: Op :&: Pos
+
+-- Signature for the simple expression language, extended with syntactic sugar
+type Sig' = Sug :+: Sug
+type SigP' = Sug :&: Pos :+: SigP
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeDifunctor, makeEqD, makeShowD,
+          smartConstructors, smartAConstructors]
+         [''Const, ''Lam, ''App, ''Op, ''Sug])
+
+instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, Difunctor f)
+  => Desugar Sug f where
+  desugHom' (Neg x)   = iConst (-1) `iMult` x
+  desugHom' (Let x y) = iLam y `iApp` x
+  desugHom' Fix       = iLam $ \f ->
+                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
+                           `iApp`
+                           (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))
+
+-- Example: desugPEx == iAApp (Pos 1 0)
+--          (iALam (Pos 1 0) Place)
+--          (iALam (Pos 1 1) $ \f ->
+--               iAApp (Pos 1 1)
+--                     (iALam (Pos 1 1) $ \x ->
+--                          iAApp (Pos 1 1) (Place f) (iAApp (Pos 1 1) (Place x) (Place x)))
+--                     (iALam (Pos 1 1) $ \x ->
+--                          iAApp (Pos 1 1) (Place f) (iAApp (Pos 1 1) (Place x) (Place x))))
+desugPEx :: Term SigP
+desugPEx = desugarA (iALet (Pos 1 0) (iAFix (Pos 1 1)) Place :: Term SigP')
diff --git a/examples/Examples/Param/Eval.hs b/examples/Examples/Param/Eval.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Param/Eval.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Param.Eval
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Expression Evaluation
+--
+-- The example illustrates how to use parametric compositional data types to
+-- implement a small expression language, with a language of values, and
+-- an evaluation function mapping expressions to values. The example
+-- demonstrates how (parametric) abstractions are mapped to general functions,
+-- from values to values, and how it is possible to project a general value
+-- (with functions) back into ground values, that can again be analysed.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Param.Eval where
+
+import Data.Comp.Param hiding (Const)
+import Data.Comp.Param.Show ()
+import Data.Comp.Param.Derive
+
+-- Signatures for values and operators
+data Const a e = Const Int
+data Lam a e = Lam (a -> e) -- Note: not e -> e
+data App a e = App e e
+data Op a e = Add e e | Mult e e
+data Fun a e = Fun (e -> e) -- Note: not a -> e
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)
+type Value = Const :+: Fun
+-- Signature for ground values.
+type GValue = Const
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeDifunctor, makeEqD, makeShowD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op])
+$(derive [makeDitraversable]
+         [''Const, ''App, ''Op])
+$(derive [smartConstructors] [''Fun])
+
+-- Term evaluation algebra
+class Eval f v where
+  evalAlg :: Alg f (Term v)
+
+$(derive [liftSum] [''Eval])
+
+-- Lift the evaluation algebra to a catamorphism
+eval :: (Difunctor f, Eval f v) => Term f -> Term v
+eval = cata evalAlg
+
+instance (Const :<: v) => Eval Const v where
+  evalAlg (Const n) = iConst n
+
+instance (Const :<: v) => Eval Op v where
+  evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
+  evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
+
+instance (Fun :<: v) => Eval App v where
+  evalAlg (App x y) = (projF x) y
+
+instance (Fun :<: v) => Eval Lam v where
+  evalAlg (Lam f) = iFun f
+
+projC :: (Const :<: v) => Term v -> Int
+projC v = case project v of Just (Const n) -> n
+
+projF :: (Fun :<: v) => Term v -> Term v -> Term v
+projF v = case project v of Just (Fun f) -> f
+
+-- |Evaluation of expressions to ground values.
+evalG :: Term Sig -> Maybe (Term GValue)
+evalG = deepProject . (eval :: Term Sig -> Term Value)
+
+-- Example: evalEx = Just (iConst 4)
+evalEx :: Maybe (Term GValue)
+evalEx = evalG $ (iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
diff --git a/examples/Examples/Param/EvalAlgM.hs b/examples/Examples/Param/EvalAlgM.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Param/EvalAlgM.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Param.EvalAlgM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Monadic Expression Evaluation without PHOAS
+--
+-- The example illustrates how to use parametric compositional data types to
+-- implement a small expression language, with a sub language of values, and a
+-- monadic evaluation function mapping expressions to values. The lack for PHOAS
+-- means that -- unlike the example in 'Examples.Param.EvalM' -- a monadic
+-- algebra can be used.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Param.EvalAlgM where
+
+import Data.Comp.Param
+import Data.Comp.Param.Show ()
+import Data.Comp.Param.Ditraversable
+import Data.Comp.Param.Derive
+import Control.Monad (liftM)
+
+-- Signature for values and operators
+data Value a e = Const Int | Pair e e
+data Op a e = Add e e | Mult e e | Fst e | Snd e
+
+-- Signature for the simple expression language
+type Sig = Op :+: Value
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeDifunctor, makeDitraversable,
+          makeEqD, makeShowD, smartConstructors]
+         [''Value, ''Op])
+
+-- Monadic term evaluation algebra
+class EvalM f v where
+  evalAlgM :: AlgM Maybe f (Term v)
+
+$(derive [liftSum] [''EvalM])
+
+-- Lift the monadic evaluation algebra to a monadic catamorphism
+evalM :: (Ditraversable f Maybe (Term v), EvalM f v) => Term f -> Maybe (Term v)
+evalM = cataM evalAlgM
+
+instance (Value :<: v) => EvalM Value v where
+  evalAlgM (Const n) = return $ iConst n
+  evalAlgM (Pair x y) = return $ iPair x y
+
+instance (Value :<: v) => EvalM Op v where
+  evalAlgM (Add x y)  = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 + n2
+  evalAlgM (Mult x y) = do n1 <- projC x
+                           n2 <- projC y
+                           return $ iConst $ n1 * n2
+  evalAlgM (Fst v)    = liftM fst $ projP v
+  evalAlgM (Snd v)    = liftM snd $ projP v
+
+projC :: (Value :<: v) => Term v -> Maybe Int
+projC v = case project v of
+            Just (Const n) -> return n
+            _ -> Nothing
+
+projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)
+projP v = case project v of
+            Just (Pair x y) -> return (x,y)
+            _ -> Nothing
+
+-- Example: evalMEx = Just (iConst 5)
+evalMEx :: Maybe (Term Value)
+evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
diff --git a/examples/Examples/Param/EvalM.hs b/examples/Examples/Param/EvalM.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Param/EvalM.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Param.EvalM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Monadic Expression Evaluation
+--
+-- The example illustrates how to use parametric compositional data types to
+-- implement a small expression language, with a language of values, and
+-- a monadic evaluation function mapping expressions to values. The example
+-- demonstrates how (parametric) abstractions are mapped to general functions,
+-- from values to /monadic/ values, and how it is possible to project a general
+-- value (with functions) back into ground values, that can again be analysed.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Param.EvalM where
+
+import Data.Comp.Param hiding (Const)
+import Data.Comp.Param.Show ()
+import Data.Comp.Param.Derive
+import Control.Monad ((<=<))
+
+-- Signatures for values and operators
+data Const a e = Const Int
+data Lam a e = Lam (a -> e) -- Note: not e -> e
+data App a e = App e e
+data Op a e = Add e e | Mult e e
+data FunM m a e = FunM (e -> m e) -- Note: not a -> m e
+
+-- Signature for the simple expression language
+type Sig = Const :+: Lam :+: App :+: Op
+-- Signature for values. Note the use of 'FunM' rather than 'Lam' (!)
+type Value = Const :+: FunM Maybe
+-- Signature for ground values.
+type GValue = Const
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeDifunctor, makeEqD, makeShowD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op])
+$(derive [makeDitraversable]
+         [''Const, ''App, ''Op])
+$(derive [smartConstructors] [''FunM])
+
+-- Term evaluation algebra. Note that we cannot use @AlgM Maybe f (Term v)@
+-- because that would force @FunM@ to have the type @e -> e@ rather than
+-- @e -> m e@. The latter is needed because the input to a @Lam@ (which is
+-- evaluated to a @Fun@) will determine whether or not an error should be
+-- returned. Example: @(\x -> x x) 42@ will produce an error because the
+-- abstraction is applied to a non-functional, whereas @(\x -> x x)(\y -> y)@
+-- will not.
+class EvalM f v where
+  evalAlgM :: Alg f (Maybe (Term v))
+
+$(derive [liftSum] [''EvalM])
+
+-- Lift the evaluation algebra to a catamorphism
+evalM :: (Difunctor f, EvalM f v) => Term f -> Maybe (Term v)
+evalM = cata evalAlgM
+
+instance (Const :<: v) => EvalM Const v where
+  evalAlgM (Const n) = return $ iConst n
+
+instance (Const :<: v) => EvalM Op v where
+  evalAlgM (Add mx my)  = do x <- projC =<< mx
+                             y <- projC =<< my
+                             return $ iConst $ x + y
+  evalAlgM (Mult mx my) = do x <- projC =<< mx
+                             y <- projC =<< my
+                             return $ iConst $ x * y
+
+instance (FunM Maybe :<: v) => EvalM App v where
+  evalAlgM (App mx my) = do f <- projF =<< mx
+                            f =<< my
+
+instance (FunM Maybe :<: v) => EvalM Lam v where
+  evalAlgM (Lam f) = return $ iFunM $ f . return
+
+projC :: (Const :<: v) => Term v -> Maybe Int
+projC v = do Const n <- project v
+             return n
+
+projF :: (FunM Maybe :<: v) => Term v -> Maybe (Term v -> Maybe (Term v))
+projF v = do FunM f <- project v
+             return f
+
+-- |Evaluation of expressions to ground values.
+evalMG :: Term Sig -> Maybe (Term GValue)
+evalMG = deepProject <=< (evalM :: Term Sig -> Maybe (Term Value))
+
+-- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12)
+evalMEx :: Maybe (Term GValue)
+evalMEx = evalMG $ (iLam $ \x -> iLam $ \y ->
+                                 Place y `iMult` (Place x `iAdd` Place x))
+                   `iApp` iConst 2 `iApp` iConst 3
diff --git a/examples/Examples/Param/Parsing.hs b/examples/Examples/Param/Parsing.hs
new file mode 100644
--- /dev/null
+++ b/examples/Examples/Param/Parsing.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, FlexibleContexts, UndecidableInstances,
+  OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Examples.Param.Parsing
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- From Parse Tree to Parametric Higher-Order Abstract Syntax
+--
+-- The example illustrates how to convert a parse tree with explicit variables
+-- into an AST which uses parametric higher-order abstract syntax instead. The
+-- example shows how we can easily convert object language binders to Haskell
+-- binders, without having to worry about capture avoidance.
+--
+--------------------------------------------------------------------------------
+
+module Examples.Param.Parsing where
+
+import Data.Comp.Param hiding (Const)
+import Data.Comp.Param.Show ()
+import Data.Comp.Param.Derive
+import Data.Comp.Param.Ditraversable
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (fromJust)
+import Control.Monad.Reader
+
+type VarId = String
+
+-- Signatures for values and operators
+data Const a e = Const Int
+data Abs a e = Abs VarId e
+data Var a e = Var VarId
+data Lam a e = Lam (a -> e) -- Note: not e -> e
+data App a e = App e e
+data Op a e = Add e e | Mult e e
+
+-- Signature for the simple expression language, parse tree
+type Sig = Const :+: Abs :+: Var :+: App :+: Op
+-- Signature for the simple expression language, PHOAS (Lam replaces Abs + Var)
+type Sig' = Const :+: Lam :+: App :+: Op
+
+-- Derive boilerplate code using Template Haskell
+$(derive [makeDifunctor, makeDitraversable, makeEqD, makeShowD, smartConstructors]
+         [''Const, ''Lam, ''App, ''Op, ''Abs, ''Var])
+
+type TransM = Reader (Map VarId Any)
+
+class PHOASTrans f g where
+  transAlg :: Alg f (TransM (Term g))
+
+$(derive [liftSum] [''PHOASTrans])
+
+-- default translation
+instance (f :<: g, Ditraversable f TransM Any) => PHOASTrans f g where
+  transAlg x = liftM inject $ disequence $ dimap (return . Place) id x
+
+instance (Lam :<: g) => PHOASTrans Abs g where
+  transAlg (Abs x b) = do env <- ask
+                          return $ iLam $ \y -> runReader b (Map.insert x y env)
+
+instance PHOASTrans Var g where
+  transAlg (Var x) = liftM (Place . fromJust) $ asks $ Map.lookup x
+
+trans :: Term Sig -> Term Sig'
+trans x = runReader (cata transAlg x) Map.empty
+
+-- Example: evalEx = iLam $ \a -> iApp (iLam $ \b -> iLam $ \c -> hole b) (hole a)
+transEx :: Term Sig'
+transEx = trans $ iAbs "y" $ (iAbs "x" $ iAbs "y" $ iVar "x") `iApp` (iVar "y")
diff --git a/src/Data/Comp.hs b/src/Data/Comp.hs
--- a/src/Data/Comp.hs
+++ b/src/Data/Comp.hs
@@ -3,34 +3,21 @@
 -- Module      :  Data.Comp
 -- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
 -- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>
 -- Stability   :  experimental
 -- Portability :  non-portable (GHC Extensions)
 --
 -- This module defines the infrastructure necessary to use
 -- /Compositional Data Types/. Compositional Data Types is an extension of
 -- Wouter Swierstra's Functional Pearl: /Data types a la carte/. Examples of
--- usage are provided below.
+-- usage are bundled with the package in the library @examples\/Examples@.
 --
 --------------------------------------------------------------------------------
 module Data.Comp(
-  -- * Examples
-  -- ** Pure Computations
-  -- $ex1
-
-  -- ** Monadic Computations
-  -- $ex2
-
-  -- ** Composing Term Homomorphisms and Algebras
-  -- $ex3
-
-  -- ** Lifting Term Homomorphisms to Products
-  -- $ex4
-
     module Data.Comp.Term
   , module Data.Comp.Algebra
   , module Data.Comp.Sum
-  , module Data.Comp.Product
+  , module Data.Comp.Annotation
   , module Data.Comp.Equality
   , module Data.Comp.Ordering
   , module Data.Comp.Generic
@@ -39,389 +26,7 @@
 import Data.Comp.Term
 import Data.Comp.Algebra
 import Data.Comp.Sum
-import Data.Comp.Product
+import Data.Comp.Annotation
 import Data.Comp.Equality
 import Data.Comp.Ordering
 import Data.Comp.Generic
-
-{- $ex1
-The example below illustrates how to use compositional data types to implement
-a small expression language, with a sub language of values, and an evaluation
-function mapping expressions to values.
-
-The following language extensions are
-needed in order to run the example: @TemplateHaskell@, @TypeOperators@,
-@MultiParamTypeClasses@, @FlexibleInstances@, @FlexibleContexts@, and
-@UndecidableInstances@.
-
-> import Data.Comp
-> import Data.Comp.Show ()
-> import Data.Comp.Derive
-> 
-> -- Signature for values and operators
-> data Value e = Const Int | Pair e e
-> data Op e = Add e e | Mult e e | Fst e | Snd e
-> 
-> -- Signature for the simple expression language
-> type Sig = Op :+: Value
-> 
-> -- Derive boilerplate code using Template Haskell
-> $(derive [instanceFunctor, instanceShowF, smartConstructors] [''Value, ''Op])
-> 
-> -- Term evaluation algebra
-> class Eval f v where
->   evalAlg :: Alg f (Term v)
-> 
-> instance (Eval f v, Eval g v) => Eval (f :+: g) v where
->   evalAlg (Inl x) = evalAlg x
->   evalAlg (Inr x) = evalAlg x
-> 
-> -- Lift the evaluation algebra to a catamorphism
-> eval :: (Functor f, Eval f v) => Term f -> Term v
-> eval = cata evalAlg
-> 
-> instance (Value :<: v) => Eval Value v where
->   evalAlg = inject
-> 
-> instance (Value :<: v) => Eval Op v where
->   evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
->   evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
->   evalAlg (Fst x)    = fst $ projP x
->   evalAlg (Snd x)    = snd $ projP x
-> 
-> projC :: (Value :<: v) => Term v -> Int
-> projC v = let Just (Const n) = project v in n
-> 
-> projP :: (Value :<: v) => Term v -> (Term v, Term v)
-> projP v = let Just (Pair x y) = project v in (x,y)
-> 
-> -- Example: evalEx = iConst 5
-> evalEx :: Term Value
-> evalEx = eval ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
--}
-
-{- $ex2
-The example below illustrates how to use compositional data types to implement
-a small expression language, with a sub language of values, and a monadic
-evaluation function mapping expressions to values.
-
-The following language
-extensions are needed in order to run the example: @TemplateHaskell@,
-@TypeOperators@, @MultiParamTypeClasses@, @FlexibleInstances@,
-@FlexibleContexts@, and @UndecidableInstances@.
-
-> import Data.Comp
-> import Data.Comp.Derive
-> import Control.Monad (liftM)
-> 
-> -- Signature for values and operators
-> data Value e = Const Int | Pair e e
-> data Op e = Add e e | Mult e e | Fst e | Snd e
-> 
-> -- Signature for the simple expression language
-> type Sig = Op :+: Value
-> 
-> -- Derive boilerplate code using Template Haskell
-> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,
->           instanceEqF, instanceShowF, smartConstructors]
->          [''Value, ''Op])
-> 
-> -- Monadic term evaluation algebra
-> class EvalM f v where
->   evalAlgM :: AlgM Maybe f (Term v)
-> 
-> instance (EvalM f v, EvalM g v) => EvalM (f :+: g) v where
->   evalAlgM (Inl x) = evalAlgM x
->   evalAlgM (Inr x) = evalAlgM x
-> 
-> -- Lift the monadic evaluation algebra to a monadic catamorphism
-> evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v)
-> evalM = cataM evalAlgM
-> 
-> instance (Value :<: v) => EvalM Value v where
->   evalAlgM = return . inject
-> 
-> instance (Value :<: v) => EvalM Op v where
->   evalAlgM (Add x y)  = do n1 <- projC x
->                            n2 <- projC y
->                            return $ iConst $ n1 + n2
->   evalAlgM (Mult x y) = do n1 <- projC x
->                            n2 <- projC y
->                            return $ iConst $ n1 * n2
->   evalAlgM (Fst v)    = liftM fst $ projP v
->   evalAlgM (Snd v)    = liftM snd $ projP v
-> 
-> projC :: (Value :<: v) => Term v -> Maybe Int
-> projC v = case project v of
->             Just (Const n) -> return n
->             _ -> Nothing
-> 
-> projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)
-> projP v = case project v of
->             Just (Pair x y) -> return (x,y)
->             _ -> Nothing
-> 
-> -- Example: evalMEx = Just (iConst 5)
-> evalMEx :: Maybe (Term Value)
-> evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
--}
-
-{- $ex3
-The example below illustrates how to compose a term homomorphism and an algebra,
-exemplified via a desugaring term homomorphism and an evaluation algebra.
-
-The following language extensions are needed in order to run the example:
-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
-@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.
-
-> import Data.Comp
-> import Data.Comp.Show ()
-> import Data.Comp.Derive
-> 
-> -- Signature for values, operators, and syntactic sugar
-> data Value e = Const Int | Pair e e
-> data Op e = Add e e | Mult e e | Fst e | Snd e
-> data Sugar e = Neg e | Swap e
->
-> -- Source position information (line number, column number)
-> data Pos = Pos Int Int
->            deriving Show
-> 
-> -- Signature for the simple expression language
-> type Sig = Op :+: Value
-> type SigP = Op :&: Pos :+: Value :&: Pos
->
-> -- Signature for the simple expression language, extended with syntactic sugar
-> type Sig' = Sugar :+: Op :+: Value
-> type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
->
-> -- Derive boilerplate code using Template Haskell
-> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,
->           instanceEqF, instanceShowF, smartConstructors]
->          [''Value, ''Op, ''Sugar])
-> 
-> -- Term homomorphism for desugaring of terms
-> class (Functor f, Functor g) => Desugar f g where
->   desugHom :: TermHom f g
->   desugHom = desugHom' . fmap Hole
->   desugHom' :: Alg f (Context g a)
->   desugHom' x = appCxt (desugHom x)
-> 
-> instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where
->   desugHom (Inl x) = desugHom x
->   desugHom (Inr x) = desugHom x
->   desugHom' (Inl x) = desugHom' x
->   desugHom' (Inr x) = desugHom' x
-> 
-> instance (Value :<: v, Functor v) => Desugar Value v where
->   desugHom = simpCxt . inj
-> 
-> instance (Op :<: v, Functor v) => Desugar Op v where
->   desugHom = simpCxt . inj
-> 
-> instance (Op :<: v, Value :<: v, Functor v) => Desugar Sugar v where
->   desugHom' (Neg x)  = iConst (-1) `iMult` x
->   desugHom' (Swap x) = iSnd x `iPair` iFst x
->
-> -- Term evaluation algebra
-> class Eval f v where
->   evalAlg :: Alg f (Term v)
-> 
-> instance (Eval f v, Eval g v) => Eval (f :+: g) v where
->   evalAlg (Inl x) = evalAlg x
->   evalAlg (Inr x) = evalAlg x
-> 
-> instance (Value :<: v) => Eval Value v where
->   evalAlg = inject
-> 
-> instance (Value :<: v) => Eval Op v where
->   evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
->   evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
->   evalAlg (Fst x)    = fst $ projP x
->   evalAlg (Snd x)    = snd $ projP x
-> 
-> projC :: (Value :<: v) => Term v -> Int
-> projC v = let Just (Const n) = project v in n
-> 
-> projP :: (Value :<: v) => Term v -> (Term v, Term v)
-> projP v = let Just (Pair x y) = project v in (x,y)
->
-> -- Compose the evaluation algebra and the desugaring homomorphism to an
-> -- algebra
-> eval :: Term Sig' -> Term Value
-> eval = cata (evalAlg `compAlg` (desugHom :: TermHom Sig' Sig))
-> 
-> -- Example: evalEx = iPair (iConst 2) (iConst 1)
-> evalEx :: Term Value
-> evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)
--}
-
-{- $ex4
-The example below illustrates how to lift a term homomorphism to products,
-exemplified via a desugaring term homomorphism lifted to terms annotated with
-source position information.
-
-The following language extensions are needed in order to run the example:
-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
-@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.
-
-> import Data.Comp
-> import Data.Comp.Show ()
-> import Data.Comp.Derive
-> 
-> -- Signature for values, operators, and syntactic sugar
-> data Value e = Const Int | Pair e e
-> data Op e = Add e e | Mult e e | Fst e | Snd e
-> data Sugar e = Neg e | Swap e
->
-> -- Source position information (line number, column number)
-> data Pos = Pos Int Int
->            deriving Show
-> 
-> -- Signature for the simple expression language
-> type Sig = Op :+: Value
-> type SigP = Op :&: Pos :+: Value :&: Pos
->
-> -- Signature for the simple expression language, extended with syntactic sugar
-> type Sig' = Sugar :+: Op :+: Value
-> type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
->
-> -- Derive boilerplate code using Template Haskell
-> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,
->           instanceEqF, instanceShowF, smartConstructors]
->          [''Value, ''Op, ''Sugar])
-> 
-> -- Term homomorphism for desugaring of terms
-> class (Functor f, Functor g) => Desugar f g where
->   desugHom :: TermHom f g
->   desugHom = desugHom' . fmap Hole
->   desugHom' :: Alg f (Context g a)
->   desugHom' x = appCxt (desugHom x)
-> 
-> instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where
->   desugHom (Inl x) = desugHom x
->   desugHom (Inr x) = desugHom x
->   desugHom' (Inl x) = desugHom' x
->   desugHom' (Inr x) = desugHom' x
-> 
-> instance (Value :<: v, Functor v) => Desugar Value v where
->   desugHom = simpCxt . inj
-> 
-> instance (Op :<: v, Functor v) => Desugar Op v where
->   desugHom = simpCxt . inj
-> 
-> instance (Op :<: v, Value :<: v, Functor v) => Desugar Sugar v where
->   desugHom' (Neg x)  = iConst (-1) `iMult` x
->   desugHom' (Swap x) = iSnd x `iPair` iFst x
-> 
-> -- Lift the desugaring term homomorphism to a catamorphism
-> desug :: Term Sig' -> Term Sig
-> desug = appTermHom desugHom
->
-> -- Example: desugEx = iPair (iConst 2) (iConst 1)
-> desugEx :: Term Sig
-> desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)
->
-> -- Lift desugaring to terms annotated with source positions
-> desugP :: Term SigP' -> Term SigP
-> desugP = appTermHom (productTermHom desugHom)
->
-> iSwapP :: (DistProd f p f', Sugar :<: f) => p -> Term f' -> Term f'
-> iSwapP p x = Term (injectP p $ inj $ Swap x)
->
-> iConstP :: (DistProd f p f', Value :<: f) => p -> Int -> Term f'
-> iConstP p x = Term (injectP p $ inj $ Const x)
->
-> iPairP :: (DistProd f p f', Value :<: f) => p -> Term f' -> Term f' -> Term f'
-> iPairP p x y = Term (injectP p $ inj $ Pair x y)
->
-> iFstP :: (DistProd f p f', Op :<: f) => p -> Term f' -> Term f'
-> iFstP p x = Term (injectP p $ inj $ Fst x)
->
-> iSndP :: (DistProd f p f', Op :<: f) => p -> Term f' -> Term f'
-> iSndP p x = Term (injectP p $ inj $ Snd x)
->
-> -- Example: desugPEx = iPairP (Pos 1 0)
-> --                            (iSndP (Pos 1 0) (iPairP (Pos 1 1)
-> --                                                     (iConstP (Pos 1 2) 1)
-> --                                                     (iConstP (Pos 1 3) 2)))
-> --                            (iFstP (Pos 1 0) (iPairP (Pos 1 1)
-> --                                                     (iConstP (Pos 1 2) 1)
-> --                                                     (iConstP (Pos 1 3) 2)))
-> desugPEx :: Term SigP
-> desugPEx = desugP $ iSwapP (Pos 1 0) (iPairP (Pos 1 1) (iConstP (Pos 1 2) 1)
->                                                        (iConstP (Pos 1 3) 2))
--}
-
-{- $ex5
-The example below illustrates how to use Higher-Order Abstract Syntax (HOAS)
-with compositional data types.
-
-The following language extensions are needed in order to run the example:
-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
-@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.
-
-> import Data.Comp
-> import Data.Comp.Show ()
-> import Data.Comp.Derive
-> 
-> -- Signature for values, operators, lambda functions, and applications
-> data Value e = Const Int | Pair e e
-> data Op e = Add e e | Mult e e | Fst e | Snd e
-> data Lam e = Lam (e -> e)
-> data App e = App e e
-> 
-> -- Signature for the extended expression language
-> type Val = Lam :+: Value
-> type Sig = App :+: Op :+: Val
->
-> -- Derive boilerplate code using Template Haskell
-> $(derive [instanceExpFunctor, smartConstructors]
->          [''Value, ''Op, ''Lam, ''App])
-> $(derive [instanceFunctor, instanceFoldable,
->           instanceTraversable, instanceShowF] [''Value])
-> 
-> -- Term evaluation algebra
-> class Eval f v where
->   evalAlg :: Alg f (Term v)
-> 
-> instance (Eval f v, Eval g v) => Eval (f :+: g) v where
->   evalAlg (Inl x) = evalAlg x
->   evalAlg (Inr x) = evalAlg x
-> 
-> instance (Value :<: v) => Eval Value v where
->   evalAlg = inject
-> 
-> instance (Value :<: v) => Eval Op v where
->   evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
->   evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
->   evalAlg (Fst x)    = fst $ projP x
->   evalAlg (Snd x)    = snd $ projP x
->
-> instance (Lam :<: v) => Eval Lam v where
->   evalAlg = inject
-> 
-> instance (Lam :<: v) => Eval App v where
->   evalAlg (App x y) = (projL x) y
-> 
-> projC :: (Value :<: v) => Term v -> Int
-> projC v = let Just (Const n) = project v in n
-> 
-> projP :: (Value :<: v) => Term v -> (Term v, Term v)
-> projP v = let Just (Pair x y) = project v in (x,y)
->
-> projL :: (Lam :<: v) => Term v -> Term v -> Term v
-> projL v = let Just (Lam f) = project v in f
->
-> -- Lift the evaluation algebra to a catamorphism. Note the use of 'cataE'
-> -- instead of 'cata'.
-> eval :: (ExpFunctor f, Eval f v) => Term f -> Term v
-> eval = cataE evalAlg
->
-> -- Example: evalEx = Just (iConst 3). Note that we need to project the value
-> -- to a value without HOAS in order to print it with 'showF'.
-> evalEx :: Maybe (Term Value)
-> evalEx = deepProject' $ (eval e :: Term Val)
->     where e :: Term Sig
->           e = (iLam $ \x -> x) `iApp` (iConst 1 `iAdd` iConst 2)
--}
diff --git a/src/Data/Comp/Algebra.hs b/src/Data/Comp/Algebra.hs
--- a/src/Data/Comp/Algebra.hs
+++ b/src/Data/Comp/Algebra.hs
@@ -34,9 +34,14 @@
       SigFun,
       TermHom,
       appTermHom,
+      appTermHom',
       compTermHom,
       appSigFun,
+      appSigFun',
       compSigFun,
+      compSigFunTermHom,
+      compTermHomSigFun,
+      compAlgSigFun,
       termHom,
       compAlg,
       compCoalg,
@@ -46,17 +51,22 @@
       CxtFunM,
       SigFunM,
       TermHomM,
-      SigFunM',
-      TermHomM',
+      SigFunMD,
+      TermHomMD,
       sigFunM,
       termHom',
       appTermHomM,
+      appTermHomM',
       termHomM,
-      termHomM',
+      termHomMD,
       appSigFunM,
       appSigFunM',
+      appSigFunMD,
       compTermHomM,
       compSigFunM,
+      compSigFunTermHomM,
+      compTermHomSigFunM,
+      compAlgSigFunM,
       compAlgM,
       compAlgM',
 
@@ -193,17 +203,21 @@
 {-| This type represents a term homomorphism. -}
 type TermHom f g = SigFun f (Context g)
 
-{-| Apply a term homomorphism recursively to a term/context. -}
-appTermHom :: (Traversable f, Functor g) => TermHom f g -> CxtFun f g
-{-# INLINE [1] appTermHom #-}
--- Constraint Traversable f is not essential and can be replaced by
--- Functor f. It is, however, needed for the shortcut-fusion rules to
--- work.
-appTermHom = appTermHom'
-
 {-| This function applies the given term homomorphism to a
 term/context. -}
-appTermHom' :: forall f g . (Functor f, Functor g) => TermHom f g -> CxtFun f g
+appTermHom :: forall f g . (Functor f, Functor g) => TermHom f g -> CxtFun f g
+{-# NOINLINE [1] appTermHom #-}
+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type
+-- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b
+-- would achieve the same. The given type is chosen for clarity.
+appTermHom f = run where
+    run :: CxtFun f g
+    run (Hole x) = Hole x
+    run (Term t) = appCxt (f (fmap run t))
+
+-- | Apply a term homomorphism recursively to a term/context. This is
+-- a top-down variant of 'appTermHom'.
+appTermHom' :: forall f g . (Functor g) => TermHom f g -> CxtFun f g
 {-# NOINLINE [1] appTermHom' #-}
 -- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type
 -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b
@@ -211,7 +225,7 @@
 appTermHom' f = run where
     run :: CxtFun f g
     run (Hole x) = Hole x
-    run (Term t) = appCxt (f (fmap run t))
+    run (Term t) = appCxt  (fmap run (f t))
 
 {-| Compose two term homomorphisms. -}
 compTermHom :: (Functor g, Functor h) => TermHom g h -> TermHom f g -> TermHom f h
@@ -219,7 +233,7 @@
 -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b))
 -- -> (a -> Cxt h f b) -> a -> Cxt h g b
 -- would achieve the same. The given type is chosen for clarity.
-compTermHom f g = appTermHom' f . g
+compTermHom f g = appTermHom f . g
 
 {-| Compose an algebra with a term homomorphism to get a new algebra. -}
 compAlg :: (Functor g) => Alg g a -> TermHom f g -> Alg f a
@@ -233,22 +247,47 @@
  -}
 compCVCoalg :: (Functor f, Functor g)
   => TermHom f g -> CVCoalg' f a -> CVCoalg' g a
-compCVCoalg hom coa = appTermHom' hom . coa
+compCVCoalg hom coa = appTermHom hom . coa
 
 
 {-| This function applies a signature function to the given context. -}
-appSigFun :: (Functor f, Functor g) => SigFun f g -> CxtFun f g
-appSigFun f = appTermHom' $ termHom f
+appSigFun :: (Functor f) => SigFun f g -> CxtFun f g
+{-# NOINLINE [1] appSigFun #-}
+appSigFun f = run
+    where run (Term t) = Term $ f $ fmap run t
+          run (Hole x) = Hole x
+-- implementation via term homomorphisms:
+--  appSigFun f = appTermHom_ $ termHom f
 
+-- | This function applies a signature function to the given
+-- context. This is a top-down variant of 'appSigFun'.
+appSigFun' :: (Functor g) => SigFun f g -> CxtFun f g
+{-# NOINLINE [1] appSigFun' #-}
+appSigFun' f = run
+    where run (Term t) = Term $ fmap run  $ f t
+          run (Hole x) = Hole x
 
+
 {-| This function composes two signature functions. -}
 compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
 compSigFun f g = f . g
 
+-- | This function composes a signature function with a term
+-- homomorphism.
+compSigFunTermHom :: (Functor g) => SigFun g h -> TermHom f g -> TermHom f h
+compSigFunTermHom f g = appSigFun f . g
 
-{-| Lifts the given signature function to the canonical term homomorphism.
--}
+-- | This function composes a term homomorphism with a signature function.
+compTermHomSigFun :: TermHom g h -> SigFun f g -> TermHom f h
+compTermHomSigFun f g = f . g
 
+-- | This function composes an algebra with a signature function.
+compAlgSigFun :: Alg g a -> SigFun f g -> Alg f a
+compAlgSigFun f g = f . g
+
+
+-- | Lifts the given signature function to the canonical term
+-- homomorphism.
 termHom :: (Functor g) => SigFun f g -> TermHom f g
 termHom f = simpCxt . f
 
@@ -263,14 +302,14 @@
 
 {-| This type represents a monadic signature function.  It is similar
 to 'SigFunM' but has monadic values also in the domain. -}
-type SigFunM' m f g = forall a. f (m a) -> m (g a)
+type SigFunMD m f g = forall a. f (m a) -> m (g a)
 
 {-| This type represents a monadic term homomorphism.  -}
 type TermHomM m f g = SigFunM m f (Context g)
 
 {-| This type represents a monadic term homomorphism. It is similar to
 'TermHomM' but has monadic values also in the domain. -}
-type TermHomM' m f g = SigFunM' m f (Context g)
+type TermHomMD m f g = SigFunMD m f (Context g)
 
 
 {-| Lift the given signature function to a monadic signature function. Note that
@@ -283,9 +322,10 @@
 termHom' :: (Functor f, Functor g, Monad m) => SigFunM m f g -> TermHomM m f g
 termHom' f = liftM  (Term . fmap Hole) . f
 
+
 {-| Lift the given signature function to a monadic term homomorphism. -}
-termHomM :: (Functor g, Monad m) => SigFun f g -> TermHomM m f g
-termHomM f = sigFunM $ termHom f
+termHomM :: (Functor g, Monad m) => SigFunM m f g -> TermHomM m f g
+termHomM f = liftM simpCxt . f
 
 
 {-| Apply a monadic term homomorphism recursively to a term/context. -}
@@ -295,40 +335,76 @@
 appTermHomM f = run
     where run :: Cxt h f a -> m (Cxt h g a)
           run (Hole x) = return (Hole x)
-          run (Term t) = liftM appCxt (f =<< mapM run t)
+          run (Term t) = liftM appCxt . f =<< mapM run t
 
+-- | Apply a monadic term homomorphism recursively to a
+-- term/context. This a top-down variant of 'appTermHomM'.
+appTermHomM' :: forall f g m . (Traversable g, Monad m)
+         => TermHomM m f g -> CxtFunM m f g
+{-# NOINLINE [1] appTermHomM' #-}
+appTermHomM' f = run
+    where run :: Cxt h f a -> m (Cxt h g a)
+          run (Hole x) = return (Hole x)
+          run (Term t) = liftM appCxt . mapM run =<< f t
+
 {-| This function constructs the unique monadic homomorphism from the
 initial term algebra to the given term algebra. -}
-termHomM' :: forall f g m . (Traversable f, Functor g, Monad m)
-          => TermHomM' m f g -> CxtFunM m f g
-termHomM' f = run 
+termHomMD :: forall f g m . (Traversable f, Functor g, Monad m)
+          => TermHomMD m f g -> CxtFunM m f g
+termHomMD f = run 
     where run :: Cxt h f a -> m (Cxt h g a)
           run (Hole x) = return (Hole x)
           run (Term t) = liftM appCxt (f (fmap run t))
 
 
 {-| This function applies a monadic signature function to the given context. -}
-appSigFunM :: (Traversable f, Functor g, Monad m) => SigFunM m f g -> CxtFunM m f g
-appSigFunM f = appTermHomM $ termHom' f
+appSigFunM :: (Traversable f, Monad m) => SigFunM m f g -> CxtFunM m f g
+{-# NOINLINE [1] appSigFunM #-}
+appSigFunM f = run
+    where run (Term t) = liftM Term . f =<< mapM run t
+          run (Hole x) = return (Hole x)
+-- implementation via term homomorphisms
+-- appSigFunM f = appTermHomM $ termHom' f
 
+
+
+-- | This function applies a monadic signature function to the given
+-- context. This is a top-down variant of 'appSigFunM'.
+appSigFunM' :: (Traversable g, Monad m) => SigFunM m f g -> CxtFunM m f g
+{-# NOINLINE [1] appSigFunM' #-}
+appSigFunM' f = run
+    where run (Term t) = liftM Term . mapM run =<< f t
+          run (Hole x) = return (Hole x)
+
 {-| This function applies a signature function to the given context. -}
-appSigFunM' :: forall f g m . (Traversable f, Functor g, Monad m)
-              => SigFunM' m f g -> CxtFunM m f g
-appSigFunM' f = run 
+appSigFunMD :: forall f g m . (Traversable f, Functor g, Monad m)
+              => SigFunMD m f g -> CxtFunM m f g
+appSigFunMD f = run 
     where run :: Cxt h f a -> m (Cxt h g a)
           run (Hole x) = return (Hole x)
           run (Term t) = liftM Term (f (fmap run t))
 
 {-| Compose two monadic term homomorphisms. -}
 compTermHomM :: (Traversable g, Functor h, Monad m)
-            => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
-compTermHomM f g =  appTermHomM f <=< g
+             => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM f g = appTermHomM f <=< g
 
+{-| Compose two monadic term homomorphisms. -}
+compTermHomM' :: (Traversable h, Monad m)
+                => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM' f g = appTermHomM' f <=< g
+
+{-| Compose two monadic term homomorphisms. -}
+compTermHomM_ :: (Functor h, Functor g, Monad m)
+                => TermHom g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM_ f g = liftM (appTermHom f) . g
+
 {-| Compose a monadic algebra with a monadic term homomorphism to get a new
   monadic algebra. -}
 compAlgM :: (Traversable g, Monad m) => AlgM m g a -> TermHomM m f g -> AlgM m f a
 compAlgM alg talg = cataM' alg <=< talg
 
+
 {-| Compose a monadic algebra with a term homomorphism to get a new monadic
   algebra. -}
 compAlgM' :: (Traversable g, Monad m) => AlgM m g a -> TermHom f g -> AlgM m f a
@@ -337,8 +413,27 @@
 
 {-| This function composes two monadic signature functions.  -}
 compSigFunM :: (Monad m) => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
-compSigFunM f g a = g a >>= f
+compSigFunM f g = f <=< g
 
+compSigFunTermHomM :: (Traversable g, Functor h, Monad m)
+                   => SigFunM m g h -> TermHomM m f g -> TermHomM m f h
+compSigFunTermHomM f g = appSigFunM f <=< g
+
+
+{-| Compose two monadic term homomorphisms. -}
+compSigFunTermHomM' :: (Traversable h, Monad m)
+                    => SigFunM m g h -> TermHomM m f g -> TermHomM m f h
+compSigFunTermHomM' f g = appSigFunM' f <=< g
+
+{-| This function composes two monadic signature functions.  -}
+compTermHomSigFunM :: (Monad m) => TermHomM m g h -> SigFunM m f g -> TermHomM m f h
+compTermHomSigFunM f g = f <=< g
+
+
+{-| This function composes two monadic signature functions.  -}
+compAlgSigFunM :: (Monad m) => AlgM m g a -> SigFunM m f g -> AlgM m f a
+compAlgSigFunM f g = f <=< g
+
 ----------------
 -- Coalgebras --
 ----------------
@@ -449,26 +544,25 @@
 type CVAlg f a f' = f (Term f') -> a
 
 
--- | This function applies 'projectP' at the tip of the term.
-
-projectTip  :: (DistProd f a f') => Term f' -> (f (Term f'), a)
-projectTip (Term v) = projectP v
+-- | This function applies 'projectA' at the tip of the term.
+projectTip  :: (DistAnn f a f') => Term f' -> (f (Term f'), a)
+projectTip (Term v) = projectA v
 
 {-| Construct a histomorphism from the given cv-algebra. -}
-histo :: (Functor f,DistProd f a f') => CVAlg f a f' -> Term f -> a
+histo :: (Functor f,DistAnn f a f') => CVAlg f a f' -> Term f -> a
 histo alg  = snd . projectTip . cata run
-    where run v = Term $ injectP (alg v) v
+    where run v = Term $ injectA (alg v) v
 
 {-| This type represents a monadic cv-algebra over a functor @f@ and carrier
   @a@. -}
 type CVAlgM m f a f' = f (Term f') -> m a
 
 {-| Construct a monadic histomorphism from the given monadic cv-algebra. -}
-histoM :: (Traversable f, Monad m, DistProd f a f') =>
+histoM :: (Traversable f, Monad m, DistAnn f a f') =>
           CVAlgM m f a f' -> Term f -> m a
 histoM alg  = liftM (snd . projectTip) . cataM run
     where run v = do r <- alg v
-                     return $ Term $ injectP r v
+                     return $ Term $ injectA r v
 
 -----------------------------------
 -- CV-Coalgebras & Futumorphisms --
@@ -507,6 +601,67 @@
           run x = appCxt $ fmap run (coa x)
 
 
+-------------------------------------------
+-- functions only used for rewrite rules --
+-------------------------------------------
+
+
+appAlgTermHom :: forall f g d . (Functor g) => Alg g d -> TermHom f g -> Term f -> d
+appAlgTermHom alg hom = run where
+    run :: Term f -> d
+    run (Term t) = run' $ hom t
+    run' :: Context g (Term f) -> d
+    run' (Term t) = alg $ fmap run' t
+    run' (Hole x) = run x
+
+
+-- | This function applies a signature function after a term homomorphism.
+appSigFunTermHom :: forall f g h. (Functor g)
+                 => SigFun g h -> TermHom f g -> CxtFun f h
+{-# NOINLINE [1] appSigFunTermHom #-}
+appSigFunTermHom f g = run where
+    run :: CxtFun f h
+    run (Term t) = run' $ g $ t
+    run (Hole h) = Hole h
+    run' :: Context g (Cxt h' f b) -> Cxt h' h b
+    run' (Term t) = Term $ f $ fmap run' t
+    run' (Hole h) = run h
+
+-- | This function applies the given algebra bottom-up while applying
+-- the given term homomorphism top-down. Thereby we have no
+-- requirements on the source signature @f@.
+appAlgTermHomM :: forall m f g a. (Traversable g, Monad m)
+               => AlgM m g a -> TermHomM m f g -> Term f -> m a
+appAlgTermHomM alg hom = run
+    where run :: Term f -> m a
+          run (Term t) = hom t >>= mapM run >>= run'
+          run' :: (Context g a) -> m a
+          run' (Term t) = mapM run' t >>= alg
+          run' (Hole x) = return x
+
+
+appTermHomTermHomM :: forall m f g h . (Monad m, Traversable g, Functor h)
+                   => TermHomM m g h -> TermHomM m f g -> CxtFunM m f h
+appTermHomTermHomM f g = run where
+    run :: CxtFunM m f h
+    run (Term t) = run' =<< g t
+    run (Hole h) = return $ Hole h
+    run' :: Context g (Cxt h' f b) -> m (Cxt h' h b)
+    run' (Term t) = liftM appCxt $ f =<< mapM run' t
+    run' (Hole h) = run h
+
+
+appSigFunTermHomM :: forall m f g h . (Traversable g, Monad m)
+                   => SigFunM m g h -> TermHomM m f g -> CxtFunM m f h
+appSigFunTermHomM f g = run where
+    run :: CxtFunM m f h
+    run (Term t) = run' =<< g t
+    run (Hole h) = return $ Hole h
+    run' :: Context g (Cxt h' f b) -> m (Cxt h' h b)
+    run' (Term t) = liftM Term $ f =<< mapM run' t
+    run' (Hole h) = run h
+
+
 -------------------
 -- rewrite rules --
 -------------------
@@ -516,19 +671,256 @@
   "cata/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x.
     cata a (appTermHom h x) = cata (compAlg a h) x;
 
+  "cata/appTermHom'" forall (a :: Alg g d) (h :: TermHom f g) x.
+    cata a (appTermHom' h x) = appAlgTermHom a h x;
+
+  "cata/appSigFun" forall (a :: Alg g d) (h :: SigFun f g) x.
+    cata a (appSigFun h x) = cata (compAlgSigFun a h) x;
+
+  "cata/appSigFun'" forall (a :: Alg g d) (h :: SigFun f g) x.
+    cata a (appSigFun' h x) = appAlgTermHom a (termHom h) x;
+
+  "cata/appSigFunTermHom" forall (f :: Alg f3 d) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    cata f (appSigFunTermHom g h x) = appAlgTermHom (compAlgSigFun f g) h x;
+
+  "appAlgTermHom/appTermHom" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appTermHom f x) = cata (compAlg a (compTermHom h f)) x;
+
+  "appAlgTermHom/appTermHom'" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appTermHom' f x) = appAlgTermHom a (compTermHom h f) x;
+
+  "appAlgTermHom/appSigFun" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appSigFun f x) = cata (compAlg a (compTermHomSigFun h f)) x;
+
+  "appAlgTermHom/appSigFun'" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appSigFun' f x) = appAlgTermHom a (compTermHomSigFun h f) x;
+
+  "appAlgTermHom/appSigFunTermHom" forall (a :: Alg i d) (f :: TermHom f g) (g :: SigFun g h)
+                                          (h :: TermHom h i) x.
+    appAlgTermHom a h (appSigFunTermHom g f x)
+      = appAlgTermHom a (compTermHom (compTermHomSigFun h g) f) x;
+
   "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.
     appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;
+
+  "appTermHom'/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom' a (appTermHom' h x) = appTermHom' (compTermHom a h) x;
+
+  "appTermHom'/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom' a (appTermHom h x) = appTermHom (compTermHom a h) x;
+
+  "appTermHom/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom a (appTermHom' h x) = appTermHom' (compTermHom a h) x;
+    
+  "appSigFun/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun f (appSigFun g x) = appSigFun (compSigFun f g) x;
+
+  "appSigFun'/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun' f (appSigFun' g x) = appSigFun' (compSigFun f g) x;
+
+  "appSigFun/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun f (appSigFun' g x) = appSigFunTermHom f (termHom g) x;
+
+  "appSigFun'/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun' f (appSigFun g x) = appSigFun (compSigFun f g) x;
+
+  "appTermHom/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;
+
+  "appTermHom/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom f (appSigFun' g x) =  appTermHom' (compTermHomSigFun f g) x;
+
+  "appTermHom'/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom' f (appSigFun' g x) =  appTermHom' (compTermHomSigFun f g) x;
+
+  "appTermHom'/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom' f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;
+    
+  "appSigFun/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun f (appTermHom g x) = appSigFunTermHom f g x;
+
+  "appSigFun'/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun' f (appTermHom' g x) = appTermHom' (compSigFunTermHom f g) x;
+
+  "appSigFun/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun f (appTermHom' g x) = appSigFunTermHom f g x;
+
+  "appSigFun'/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun' f (appTermHom g x) = appTermHom (compSigFunTermHom f g) x;
+    
+  "appSigFunTermHom/appSigFun" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: SigFun f1 f2) x.
+    appSigFunTermHom f g (appSigFun h x)
+    = appSigFunTermHom f (compTermHomSigFun g h) x;
+
+  "appSigFunTermHom/appSigFun'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: SigFun f1 f2) x.
+    appSigFunTermHom f g (appSigFun' h x)
+    = appSigFunTermHom f (compTermHomSigFun g h) x;
+
+  "appSigFunTermHom/appTermHom" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFunTermHom f g (appTermHom h x)
+    = appSigFunTermHom f (compTermHom g h) x;
+
+  "appSigFunTermHom/appTermHom'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFunTermHom f g (appTermHom' h x)
+    = appSigFunTermHom f (compTermHom g h) x;
+
+  "appSigFun/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFun f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;
+
+  "appSigFun'/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFun' f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;
+
+  "appTermHom/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appTermHom f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;
+
+  "appTermHom'/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appTermHom' f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;
+
+  "appSigFunTermHom/appSigFunTermHom" forall (f1 :: SigFun f4 f5) (f2 :: TermHom f3 f4)
+                                             (f3 :: SigFun f2 f3) (f4 :: TermHom f1 f2) x.
+    appSigFunTermHom f1 f2 (appSigFunTermHom f3 f4 x)
+      = appSigFunTermHom f1 (compTermHom (compTermHomSigFun f2 f3) f4) x;
  #-}
 
 {-# RULES 
-  "cataM/appTermHomM" forall (a :: AlgM m g d) (h :: TermHomM m f g) x.
-     appTermHomM h x >>= cataM a = cataM (compAlgM a h) x;
+  "cataM/appTermHomM" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= cataM a =  appAlgTermHomM a h x;
 
+  "cataM/appTermHomM'" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= cataM a = appAlgTermHomM a h x;
+
+  "cataM/appSigFunM" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= cataM a =  appAlgTermHomM a (termHomM h) x;
+
+  "cataM/appSigFunM'" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= cataM a = appAlgTermHomM a (termHomM h) x;
+
   "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.
-     cataM a (appTermHom h x) = cataM (compAlgM' a h) x;
+     cataM a (appTermHom h x) = appAlgTermHomM a (sigFunM h) x;
 
-  "appTermHomM/appTermHomM" forall (a :: TermHomM m g h) (h :: TermHomM m f g) x.
-    appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;
+  "cataM/appTermHom'" forall (a :: AlgM m g d) (h :: TermHom f g) x.
+     cataM a (appTermHom' h x) = appAlgTermHomM a (sigFunM h) x;
+
+  "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.
+     cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;
+
+  "cataM/appSigFun'" forall (a :: AlgM m g d) (h :: SigFun f g) x.
+     cataM a (appSigFun' h x) = appAlgTermHomM a (sigFunM $ termHom h) x;
+
+  "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.
+     cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;
+
+  "cataM/appSigFunTermHom" forall (a :: AlgM m h d) (g :: SigFun g h) (f :: TermHom f g) x.
+     cataM a (appSigFunTermHom g f x) = appAlgTermHomM a (sigFunM $ compSigFunTermHom g f) x;
+
+  "appTermHomM/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;
+
+  "appTermHomM/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appTermHomM a = appTermHomM (compTermHomSigFunM a h) x;
+
+  "appTermHomM/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appTermHomM a = appTermHomTermHomM a h x;
+
+  "appTermHomM/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appTermHomM a = appTermHomTermHomM a (termHomM h) x;
+
+  "appTermHomM'/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;
+
+  "appTermHomM'/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;
+
+  "appTermHomM'/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;
+
+  "appTermHomM'/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;
+
+  "appTermHomM/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM a (appTermHom h x) = appTermHomTermHomM a (sigFunM h) x;
+
+  "appTermHomM/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM a (appSigFun h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;
+
+  "appTermHomM'/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM' a (appTermHom h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;
+
+  "appTermHomM'/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM' a (appSigFun h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;
+
+  "appTermHomM/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM a (appTermHom' h x) = appTermHomTermHomM a (sigFunM h) x;
+
+  "appTermHomM/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM a (appSigFun' h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;
+
+  "appTermHomM'/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM' a (appTermHom' h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;
+
+  "appTermHomM'/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM' a (appSigFun' h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;
+
+  "appSigFunM/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appSigFunM a = appSigFunTermHomM a h x;
+
+  "appSigFunHomM/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appSigFunM a = appSigFunM (compSigFunM a h) x;
+
+  "appSigFunM/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appSigFunM a = appSigFunTermHomM a h x;
+
+  "appSigFunM/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appSigFunM a = appSigFunTermHomM a (termHomM h) x;
+
+  "appSigFunM'/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' a h) x;
+
+  "appSigFunM'/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x;
+
+  "appSigFunM'/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' a h) x;
+
+  "appSigFunM'/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x;
+
+  "appSigFunM/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM a (appTermHom h x) = appSigFunTermHomM a (sigFunM h) x;
+
+  "appSigFunM/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM a (appSigFun h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;
+
+  "appSigFunM'/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM' a (appTermHom h x) = appTermHomM' (compSigFunTermHomM' a (sigFunM h)) x;
+
+  "appSigFunM'/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM' a (appSigFun h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;
+
+  "appSigFunM/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM a (appTermHom' h x) = appSigFunTermHomM a (sigFunM h) x;
+
+  "appSigFunM/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM a (appSigFun' h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;
+
+  "appSigFunM'/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM' a (appTermHom' h x) = appTermHomM' (compSigFunTermHomM' a (sigFunM h)) x;
+
+  "appSigFunM'/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM' a (appSigFun' h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;
+
+
+  "appTermHom/appTermHomM" forall (a :: TermHom g h) (h :: TermHomM m f g) x.
+     appTermHomM h x >>= (return . appTermHom a) = appTermHomM (compTermHomM_ a h) x;
  #-}
 
 {-# RULES
diff --git a/src/Data/Comp/Annotation.hs b/src/Data/Comp/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Annotation.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, RankNTypes, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Annotation
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines annotations on signatures.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Annotation
+    (
+     (:&:) (..),
+     (:*:) (..),
+     DistAnn (..),
+     RemA (..),
+     liftA,
+     liftA',
+     stripA,
+     propAnn,
+     propAnnM,
+     ann,
+     project'
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Ops
+import Data.Comp.Algebra
+import Control.Monad
+
+{-| Transform a function with a domain constructed from a functor to a function
+ with a domain constructed with the same functor, but with an additional
+ annotation. -}
+liftA :: (RemA s s') => (s' a -> t) -> s a -> t
+liftA f v = f (remA v)
+
+{-| Transform a function with a domain constructed from a functor to a function
+  with a domain constructed with the same functor, but with an additional
+  annotation. -}
+liftA' :: (DistAnn s' p s, Functor s')
+       => (s' a -> Cxt h s' a) -> s a -> Cxt h s a
+liftA' f v = let (v',p) = projectA v
+             in ann p (f v')
+    
+{-| Strip the annotations from a term over a functor with annotations. -}
+stripA :: (RemA g f, Functor g) => CxtFun g f
+stripA = appSigFun remA
+
+{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism
+ over the same signatures, but extended with annotations. -}
+propAnn :: (DistAnn f p f', DistAnn g p g', Functor g) 
+        => TermHom f g -> TermHom f' g'
+propAnn hom f' = ann p (hom f)
+    where (f,p) = projectA f'
+
+{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic
+  term homomorphism over the same signatures, but extended with annotations. -}
+propAnnM :: (DistAnn f p f', DistAnn g p g', Functor g, Monad m) 
+         => TermHomM m f g -> TermHomM m f' g'
+propAnnM hom f' = liftM (ann p) (hom f)
+    where (f,p) = projectA f'
+
+{-| Annotate each node of a term with a constant value. -}
+ann :: (DistAnn f p g, Functor f) => p -> CxtFun f g
+ann c = appSigFun (injectA c)
+
+{-| This function is similar to 'project' but applies to signatures
+with an annotation which is then ignored. -}
+-- bug in type checker? below is the inferred type, however, the type checker
+-- rejects it.
+-- project' :: (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))
+project' v = liftM remA $ project v
diff --git a/src/Data/Comp/Arbitrary.hs b/src/Data/Comp/Arbitrary.hs
--- a/src/Data/Comp/Arbitrary.hs
+++ b/src/Data/Comp/Arbitrary.hs
@@ -20,7 +20,7 @@
 import Test.QuickCheck
 import Data.Comp.Term
 import Data.Comp.Sum
-import Data.Comp.Product
+import Data.Comp.Ops
 import Data.Comp.Derive.Utils
 import Data.Comp.Derive
 import Control.Applicative
@@ -31,8 +31,6 @@
 instance (ArbitraryF f) => Arbitrary (Term f) where
     arbitrary = Term <$> arbitraryF
     shrink (Term expr) = map Term $ shrinkF expr
-    
-    
 
 instance (ArbitraryF f, Arbitrary p) => ArbitraryF (f :&: p) where
     arbitraryF' = map addP arbitraryF'
@@ -68,4 +66,4 @@
     shrinkF (Inr val) = map Inr (shrinkF val)
 
 
-$(derive [instanceArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)
+$(derive [makeArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)
diff --git a/src/Data/Comp/Automata.hs b/src/Data/Comp/Automata.hs
deleted file mode 100644
--- a/src/Data/Comp/Automata.hs
+++ /dev/null
@@ -1,147 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Automata
--- Copyright   :  (c) 2010-2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- This module defines tree automata based on compositional data types.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Automata where
-
-import Data.Comp
-import Data.Maybe
-import Data.Traversable
-import Control.Monad
-
-
-{-| This type represents transition functions of deterministic
-bottom-up tree acceptors (DUTAs).  -}
-
-type DUTATrans f q = Alg f q
-
-{-| This data type represents deterministic bottom-up tree acceptors (DUTAs).
--}
-data DUTA f q = DUTA {
-      dutaTrans :: DUTATrans f q,
-      dutaAccept :: q -> Bool
-    }
-
-{-| This function runs the transition function of a DUTA on the given
-term. -}
-
-runDUTATrans :: Functor f => DUTATrans f q -> Term f -> q
-runDUTATrans = cata
-
-{-| This function checks whether a given DUTA accepts a term.  -}
-
-duta :: Functor f => DUTA f q -> Term f -> Bool
-duta DUTA{dutaTrans = trans, dutaAccept = accept} = accept . runDUTATrans trans
-
-
-
-{-| This type represents transition functions of non-deterministic
-bottom-up tree acceptors (NUTAs).  -}
-
-type NUTATrans f q = AlgM [] f q
-
-
-{-| This type represents non-deterministic bottom-up tree acceptors.
--}
-data NUTA f q = NUTA {
-      nutaTrans :: AlgM [] f q,
-      nutaAccept :: q -> Bool
-    }
-
-{-| This function runs the given transition function of a NUTA on the
-given term -}
-
-runNUTATrans :: Traversable f => NUTATrans f q -> Term f -> [q]
-runNUTATrans = cataM
-
-{-| This function checks whether a given NUTA accepts a term. -}
-
-nuta :: Traversable f => NUTA f q -> Term f -> Bool
-nuta NUTA{nutaTrans = trans, nutaAccept = accept} = any accept . runNUTATrans trans
-
-
-{-| This function determinises the given NUTA.  -}
-
-determNUTA :: (Traversable f) => NUTA f q -> DUTA f [q]
-determNUTA n = DUTA{
-               dutaTrans = algM $ nutaTrans n,
-               dutaAccept = any $ nutaAccept n}
-
-{-| This function represents transition functions of
-deterministic bottom-up tree transducers (DUTTs).  -}
-
-type DUTTTrans f g q = forall a. f (q,a) -> (q, Cxt Hole g a)
-
-{-| This function transforms a DUTT transition function into an
-algebra.  -}
-
-duttTransAlg :: (Functor f, Functor g)  => DUTTTrans f g q -> Alg f (q, Term g)
-duttTransAlg trans = fmap injectCxt . trans 
-
-{-| This function runs the given DUTT transition function on the given
-term.  -}
-
-runDUTTTrans :: (Functor f, Functor g)  => DUTTTrans f g q -> Term f -> (q, Term g)
-runDUTTTrans = cata . duttTransAlg
-
-{-| This data type represents deterministic bottom-up tree
-transducers. -}
-
-data DUTT f g q = DUTT {
-      duttTrans :: DUTTTrans f g q,
-      duttAccept :: q -> Bool
-    }
-
-{-| This function transforms the given term according to the given
-DUTT and returns the resulting term provided it is accepted by the
-DUTT. -}
-
-dutt :: (Functor f, Functor g) => DUTT f g q -> Term f -> Maybe (Term g)
-dutt DUTT{duttTrans = trans, duttAccept = accept} = accept' . runDUTTTrans trans
-    where accept' (q,res)
-              | accept q = Just res
-              | otherwise = Nothing
-
-{-| This type represents transition functions of non-deterministic
-bottom-up tree transducers (NUTTs).  -}
-
-type NUTTTrans f g q = forall a. f (q,a) -> [(q, Cxt Hole g a)]
-
-{-| This function transforms a NUTT transition function into a monadic
-algebra.  -}
-
-nuttTransAlg :: (Functor f, Functor g)  => NUTTTrans f g q -> AlgM [] f (q, Term g)
-nuttTransAlg trans = liftM (fmap injectCxt) . trans 
-
-{-| This function runs the given NUTT transition function on the given
-term.  -}
-
-runNUTTTrans :: (Traversable f, Functor g)  => NUTTTrans f g q -> Term f -> [(q, Term g)]
-runNUTTTrans = cataM . nuttTransAlg
-
-{-| This data type represents non-deterministic bottom-up tree
-transducers (NUTTs). -}
-
-data NUTT f g q = NUTT {
-      nuttTrans :: NUTTTrans f g q,
-      nuttAccept :: q -> Bool
-    }
-
-{-| This function transforms the given term according to the given
-NUTT and returns a list containing all accepted results. -}
-
-nutt :: (Traversable f, Functor g) => NUTT f g q -> Term f -> [Term g]
-nutt NUTT{nuttTrans = trans, nuttAccept = accept} = mapMaybe accept' . runNUTTTrans trans
-    where accept' (q,res)
-              | accept q = Just res
-              | otherwise = Nothing
diff --git a/src/Data/Comp/DeepSeq.hs b/src/Data/Comp/DeepSeq.hs
--- a/src/Data/Comp/DeepSeq.hs
+++ b/src/Data/Comp/DeepSeq.hs
@@ -22,7 +22,6 @@
     where
 
 import Data.Comp.Term
-import Data.Comp.Sum
 import Control.DeepSeq
 import Data.Comp.Derive
 import Data.Foldable
@@ -36,11 +35,7 @@
     rnf (Hole x) = rnf x
     rnf (Term x) = rnfF x
 
-instance (NFDataF f, NFDataF g) => NFDataF (f:+:g) where
-    rnfF (Inl v) = rnfF v
-    rnfF (Inr v) = rnfF v
-
 instance NFData Nothing where
 
-
-$(derive [instanceNFDataF] [''Maybe, ''[], ''(,)])
+$(derive [liftSum] [''NFDataF])
+$(derive [makeNFDataF] [''Maybe, ''[], ''(,)])
diff --git a/src/Data/Comp/Derive.hs b/src/Data/Comp/Derive.hs
--- a/src/Data/Comp/Derive.hs
+++ b/src/Data/Comp/Derive.hs
@@ -16,9 +16,7 @@
 module Data.Comp.Derive
     (
      derive,
-     -- * First-order Signatures
-     -- |Derive boilerplate instances for first-order signatures, i.e.
-     -- signatures for ordinary compositional data types.
+     -- |Derive boilerplate instances for compositional data type signatures.
 
      -- ** ShowF
      module Data.Comp.Derive.Show,
@@ -28,7 +26,7 @@
      module Data.Comp.Derive.Ordering,
      -- ** Functor
      Functor,
-     instanceFunctor,
+     makeFunctor,
      -- ** Foldable
      module Data.Comp.Derive.Foldable,
      -- ** Traversable
@@ -36,31 +34,19 @@
      -- ** Arbitrary
      module Data.Comp.Derive.Arbitrary,
      NFData(..),
-     instanceNFData,
+     makeNFData,
      -- ** DeepSeq
      module Data.Comp.Derive.DeepSeq,
      -- ** Smart Constructors
      module Data.Comp.Derive.SmartConstructors,
-
-     -- * Higher-order Signatures
-     -- |Derive boilerplate instances for higher-order signatures, i.e.
-     -- signatures for generalised compositional data types.
-
-     -- ** HShowF
-     module Data.Comp.Derive.Multi.Show,
-     -- ** HEqF
-     module Data.Comp.Derive.Multi.Equality,
-     -- ** HFunctor
-     module Data.Comp.Derive.Multi.Functor,
-     -- ** HFoldable
-     module Data.Comp.Derive.Multi.Foldable,
-     -- ** HTraversable
-     module Data.Comp.Derive.Multi.Traversable,
-     -- ** Smart Constructors
-     module Data.Comp.Derive.Multi.SmartConstructors
+     -- ** Smart Constructors w/ Annotations
+     module Data.Comp.Derive.SmartAConstructors,
+     -- ** Lifting to Sums
+     module Data.Comp.Derive.LiftSum
     ) where
 
 import Control.DeepSeq (NFData(..))
+import Data.Comp.Derive.Utils (derive)
 import Data.Comp.Derive.Foldable
 import Data.Comp.Derive.Traversable
 import Data.Comp.Derive.DeepSeq
@@ -69,34 +55,19 @@
 import Data.Comp.Derive.Equality
 import Data.Comp.Derive.Arbitrary
 import Data.Comp.Derive.SmartConstructors
-import Data.Comp.Derive.Multi.Equality
-import Data.Comp.Derive.Multi.Show
-import Data.Comp.Derive.Multi.Functor
-import Data.Comp.Derive.Multi.Foldable
-import Data.Comp.Derive.Multi.Traversable
-import Data.Comp.Derive.Multi.SmartConstructors
+import Data.Comp.Derive.SmartAConstructors
+import Data.Comp.Derive.LiftSum
 
 import Language.Haskell.TH
-import Control.Monad
 
 import qualified Data.DeriveTH as D
-import Data.Derive.All
-
-{-| Helper function for generating a list of instances for a list of named
- signatures. For example, in order to derive instances 'Functor' and
- 'ShowF' for a signature @Exp@, use derive as follows (requires Template
- Haskell):
-
- > $(derive [instanceFunctor, instanceShowF] [''Exp])
- -}
-derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
-derive ders names = liftM concat $ sequence [der name | der <- ders, name <- names]
+import qualified Data.Derive.All as A
 
 {-| Derive an instance of 'Functor' for a type constructor of any first-order
   kind taking at least one argument. -}
-instanceFunctor :: Name -> Q [Dec]
-instanceFunctor = D.derive makeFunctor
+makeFunctor :: Name -> Q [Dec]
+makeFunctor = D.derive A.makeFunctor
 
 {-| Derive an instance of 'NFData' for a type constructor. -}
-instanceNFData :: Name -> Q [Dec]
-instanceNFData = D.derive makeNFData
+makeNFData :: Name -> Q [Dec]
+makeNFData = D.derive A.makeNFData
diff --git a/src/Data/Comp/Derive/Arbitrary.hs b/src/Data/Comp/Derive/Arbitrary.hs
--- a/src/Data/Comp/Derive/Arbitrary.hs
+++ b/src/Data/Comp/Derive/Arbitrary.hs
@@ -15,19 +15,19 @@
 module Data.Comp.Derive.Arbitrary
     (
      ArbitraryF(..),
-     instanceArbitraryF,
+     makeArbitraryF,
      Arbitrary(..),
-     instanceArbitrary
+     makeArbitrary
     )where
 
 import Test.QuickCheck
-import Data.Comp.Derive.Utils
+import Data.Comp.Derive.Utils hiding (derive)
 import Language.Haskell.TH
-import Data.DeriveTH
+import qualified Data.DeriveTH as D
 
 {-| Derive an instance of 'Arbitrary' for a type constructor. -}
-instanceArbitrary :: Name -> Q [Dec]
-instanceArbitrary = derive makeArbitrary
+makeArbitrary :: Name -> Q [Dec]
+makeArbitrary = D.derive D.makeArbitrary
 
 {-| Signature arbitration. An instance @ArbitraryF f@ gives rise to an instance
   @Arbitrary (Term f)@. -}
@@ -43,8 +43,8 @@
   first-order kind taking at least one argument. It is necessary that
   all types that are used by the data type definition are themselves
   instances of 'Arbitrary'. -}
-instanceArbitraryF :: Name -> Q [Dec]
-instanceArbitraryF dt = do
+makeArbitraryF :: Name -> Q [Dec]
+makeArbitraryF dt = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt
   let argNames = (map (VarT . tyVarBndrName) (tail args))
       complType = foldl AppT (ConT name) argNames
diff --git a/src/Data/Comp/Derive/DeepSeq.hs b/src/Data/Comp/Derive/DeepSeq.hs
--- a/src/Data/Comp/Derive/DeepSeq.hs
+++ b/src/Data/Comp/Derive/DeepSeq.hs
@@ -15,7 +15,7 @@
 module Data.Comp.Derive.DeepSeq
     (
      NFDataF(..),
-     instanceNFDataF
+     makeNFDataF
     ) where
 
 
@@ -31,8 +31,8 @@
 
 {-| Derive an instance of 'NFDataF' for a type constructor of any first-order
   kind taking at least one argument. -}
-instanceNFDataF :: Name -> Q [Dec]
-instanceNFDataF fname = do
+makeNFDataF :: Name -> Q [Dec]
+makeNFDataF fname = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
   let fArg = VarT . tyVarBndrName $ last args
       argNames = (map (VarT . tyVarBndrName) (init args))
diff --git a/src/Data/Comp/Derive/Equality.hs b/src/Data/Comp/Derive/Equality.hs
--- a/src/Data/Comp/Derive/Equality.hs
+++ b/src/Data/Comp/Derive/Equality.hs
@@ -14,7 +14,7 @@
 module Data.Comp.Derive.Equality
     (
      EqF(..),
-     instanceEqF
+     makeEqF
     ) where
 
 import Data.Comp.Derive.Utils
@@ -29,8 +29,8 @@
 
 {-| Derive an instance of 'EqF' for a type constructor of any first-order kind
   taking at least one argument. -}
-instanceEqF :: Name -> Q [Dec]
-instanceEqF fname = do
+makeEqF :: Name -> Q [Dec]
+makeEqF fname = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
   let argNames = (map (VarT . tyVarBndrName) (init args))
       complType = foldl AppT (ConT name) argNames
diff --git a/src/Data/Comp/Derive/Foldable.hs b/src/Data/Comp/Derive/Foldable.hs
--- a/src/Data/Comp/Derive/Foldable.hs
+++ b/src/Data/Comp/Derive/Foldable.hs
@@ -15,7 +15,7 @@
 module Data.Comp.Derive.Foldable
     (
      Foldable,
-     instanceFoldable
+     makeFoldable
     ) where
 
 import Data.Comp.Derive.Utils
@@ -38,8 +38,8 @@
 
 {-| Derive an instance of 'Foldable' for a type constructor of any first-order
   kind taking at least one argument. -}
-instanceFoldable :: Name -> Q [Dec]
-instanceFoldable fname = do
+makeFoldable :: Name -> Q [Dec]
+makeFoldable fname = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
   let fArg = VarT . tyVarBndrName $ last args
       argNames = (map (VarT . tyVarBndrName) (init args))
diff --git a/src/Data/Comp/Derive/Injections.hs b/src/Data/Comp/Derive/Injections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Injections.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Injections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature injections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Injections
+    (
+     injn,
+     injectn,
+     deepInjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Term
+import Data.Comp.Algebra (CxtFun, appSigFun)
+import Data.Comp.Ops ((:+:)(..), (:<:)(..))
+
+injn :: Int -> Q [Dec]
+injn n = do
+  let i = mkName $ "inj" ++ show n
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let xvar = mkName "x"
+  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar) : d
+    where genSig fvars gvar avar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = arrowT `appT` (tp `appT` varT avar)
+                             `appT` (varT gvar `appT` varT avar)
+            forallT (map PlainTV $ gvar : avar : fvars)
+                    (sequence cxt) tp'
+          genDecl x n = [| case $(varE x) of
+                             Inl x -> $(varE $ mkName $ "inj") x
+                             Inr x -> $(varE $ mkName $ "inj" ++
+                                        if n > 2 then show (n - 1) else "") x |]
+injectn :: Int -> Q [Dec]
+injectn n = do
+  let i = mkName ("inject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar) : d
+    where genSig fvars gvar avar = do
+            let hvar = mkName "h"
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar
+                                 `appT` varT avar
+            let tp'' = arrowT `appT` (tp `appT` tp') `appT` tp'
+            forallT (map PlainTV $ hvar : gvar : avar : fvars)
+                    (sequence cxt) tp''
+          genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]
+
+deepInjectn :: Int -> Q [Dec]
+deepInjectn n = do
+  let i = mkName ("deepInject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar) : d
+    where genSig fvars gvar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let cxt' = classP ''Functor [tp]
+            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar
+            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
diff --git a/src/Data/Comp/Derive/LiftSum.hs b/src/Data/Comp/Derive/LiftSum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/LiftSum.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.LiftSum
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Lift a class declaration for difunctors to sums of functors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.LiftSum
+    (
+     liftSum,
+     caseF
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Sum
+import Data.Comp.Ops ((:+:)(..))
+
+{-| Given the name of a type class, where the first parameter is a functor,
+  lift it to sums of functors. Example: @class ShowF f where ...@ is lifted
+  as @instance (ShowF f, ShowF g) => ShowF (f :+: g) where ... @. -}
+liftSum :: Name -> Q [Dec]
+liftSum fname = do
+  ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname
+  let targs' = map tyVarBndrName $ tail targs
+  let f = mkName "f"
+  let g = mkName "g"
+  let cxt = [ClassP name (map VarT $ f : targs'),
+             ClassP name (map VarT $ g : targs')]
+  let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)
+  let complType = foldl (\a x -> a `AppT` VarT x) tp targs'
+  decs' <- sequence $ concatMap decl decs
+  return [InstanceD cxt complType decs']
+      where decl :: Dec -> [DecQ]
+            decl (SigD f _) = [funD f [clause f]]
+            decl _ = []
+            clause :: Name -> ClauseQ
+            clause f = do x <- newName "x"
+                          b <- normalB [|caseF $(varE f) $(varE f) $(varE x)|]
+                          return $ Clause [VarP x] b []
+
+{-| Utility function to case on a functor sum, without exposing the internal
+  representation of sums. -}
+caseF :: (f a -> b) -> (g a -> b) -> (f :+: g) a -> b
+caseF f g x = case x of
+                Inl x -> f x
+                Inr x -> g x
diff --git a/src/Data/Comp/Derive/Multi/Equality.hs b/src/Data/Comp/Derive/Multi/Equality.hs
deleted file mode 100644
--- a/src/Data/Comp/Derive/Multi/Equality.hs
+++ /dev/null
@@ -1,81 +0,0 @@
-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Derive.Multi.Equality
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- Automatically derive instances of @HEqF@.
---
---------------------------------------------------------------------------------
-module Data.Comp.Derive.Multi.Equality
-    (
-     HEqF(..),
-     KEq(..),
-     instanceHEqF
-    ) where
-
-import Data.Comp.Derive.Utils
-import Data.Comp.Multi.Functor
-import Language.Haskell.TH hiding (Cxt, match)
-
-
-class KEq f where
-    keq :: f i -> f j -> Bool
-
-{-| Signature equality. An instance @HEqF f@ gives rise to an instance
-  @KEq (HTerm f)@. -}
-class HEqF f where
-
-    heqF :: KEq g => f g i -> f g j -> Bool
-
-
-instance KEq f => Eq (f i) where
-    (==) = keq
-
-instance Eq a => KEq (K a) where
-    keq (K x) (K y) = x == y
-
-instance KEq a => Eq (A a) where
-     A x == A y = x `keq`  y
-
-{-| Derive an instance of 'HEqF' for a type constructor of any higher-order
-  kind taking at least two arguments. -}
-instanceHEqF :: Name -> Q [Dec]
-instanceHEqF fname = do
-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
-  let args' = init args
-      argNames = (map (VarT . tyVarBndrName) (init args'))
-      ftyp = VarT . tyVarBndrName $ last args'
-      complType = foldl AppT (ConT name) argNames
-      preCond = map (ClassP ''Eq . (: [])) argNames
-      classType = AppT (ConT ''HEqF) complType
-  constrs' <- mapM normalConExp constrs
-  eqFDecl <- funD 'heqF  (eqFClauses ftyp constrs constrs')
-  return [InstanceD preCond classType [eqFDecl]]
-      where eqFClauses ftyp constrs constrs' = map (genEqClause ftyp) constrs'
-                                   ++ defEqClause constrs
-            filterFarg fArg ty x = (containsType ty fArg, varE x)
-            defEqClause constrs
-                | length constrs  < 2 = []
-                | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]
-            genEqClause ftyp (constr, argts) = do 
-              let n = length argts
-              varNs <- newNames n "x"
-              varNs' <- newNames n "y"
-              let pat = ConP constr $ map VarP varNs
-                  pat' = ConP constr $ map VarP varNs'
-                  vars = map VarE varNs
-                  vars' = map VarE varNs'
-                  mkEq ty x y = let (x',y') = (return x,return y)
-                                in if containsType ty ftyp
-                                   then [| $x' `keq` $y'|]
-                                   else [| $x' == $y'|]
-                  eqs = listE $ zipWith3 mkEq argts vars vars'
-              body <- if n == 0 
-                      then [|True|]
-                      else [|and $eqs|]
-              return $ Clause [pat, pat'] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Multi/Foldable.hs b/src/Data/Comp/Derive/Multi/Foldable.hs
deleted file mode 100644
--- a/src/Data/Comp/Derive/Multi/Foldable.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Derive.Multi.Foldable
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- Automatically derive instances of @HFoldable@.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Derive.Multi.Foldable
-    (
-     HFoldable,
-     instanceHFoldable
-    )where
-
-import Data.Comp.Derive.Utils
-import Data.Comp.Multi.Functor
-import Data.Comp.Multi.Foldable
-import Data.Foldable
-import Language.Haskell.TH
-import Data.Monoid
-import Data.Maybe
-import qualified Prelude as P (foldl,foldr,foldl1)
-import Prelude hiding  (foldl,foldr,foldl1)
-import Control.Monad
-
-
-iter 0 _ e = e
-iter n f e = iter (n-1) f (f `appE` e)
-
-iter' n f e = run n f e
-    where run 0 _ e = e
-          run m f e = let f' = iter (m-1) [|fmap|] f
-                      in run (m-1) f (f' `appE` e)
-
-iterSp n f g e = run n e
-    where run 0 e = e
-          run m e = let f' = iter (m-1) [|fmap|] (if n == m then g else f)
-                    in run (m-1) (f' `appE` e)
-
-{-| Derive an instance of 'HFoldable' for a type constructor of any higher-order
-  kind taking at least two arguments. -}
-instanceHFoldable :: Name -> Q [Dec]
-instanceHFoldable fname = do
-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
-  let args' = init args
-      fArg = VarT . tyVarBndrName $ last args'
-      argNames = (map (VarT . tyVarBndrName) (init args'))
-      complType = P.foldl AppT (ConT name) argNames
-      classType = AppT (ConT ''HFoldable) complType
-  constrs' <- mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
-  foldDecl <- funD 'hfold (map foldClause constrs')
-  foldMapDecl <- funD 'hfoldMap (map foldMapClause constrs')
-  foldlDecl <- funD 'hfoldl (map foldlClause constrs')
-  foldrDecl <- funD 'hfoldr (map foldrClause constrs')
-  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl]]
-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)
-            filterVar [] _ = Nothing
-            filterVar [d] x =Just (d, varE x)
-            filterVar _ _ =  error "functor variable occurring twice in argument type"
-            filterVars args varNs = catMaybes $ zipWith filterVar args varNs
-            mkCPat constr args varNs = ConP constr $ zipWith mkPat args varNs
-            mkPat [] _ = WildP
-            mkPat _ x = VarP x
-            mkPatAndVars (constr, args) =
-                do varNs <- newNames (length args) "x"
-                   return (mkCPat constr args varNs, filterVars args varNs)
-            foldClause (pat,vars) =
-                do let conApp (0,x) = [|unK $x|]
-                       conApp (d,x) = iterSp d [|fold|] [| foldMap unK |] x
-                   body <- if null vars
-                           then [|mempty|]
-                           else P.foldl1 (\ x y -> [|$x `mappend` $y|])
-                                    $ map conApp vars
-                   return $ Clause [pat] (NormalB body) []
-            foldMapClause (pat,vars) =
-                do fn <- newName "y"
-                   let f = varE fn
-                       f' 0 = f
-                       f' n = iter (n-1) [|fmap|] [| foldMap $f |]
-                       fp = if null vars then WildP else VarP fn
-                   body <- case vars of
-                             [] -> [|mempty|]
-                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $ 
-                                      map (\ (d,z) -> iter' (max (d-1) 0) [|fold|] (f' d `appE` z)) vars
-                   return $ Clause [fp, pat] (NormalB body) []
-            foldlClause (pat,vars) =
-                do fn <- newName "f"
-                   en <- newName "e"
-                   let f = varE fn
-                       e = varE en
-                       fp = if null vars then WildP else VarP fn
-                       ep = VarP en
-                       conApp x (0,y) = [|$f $x $y|]
-                       conApp x (1,y) = [|foldl $f $x $y|]
-                       conApp x (d,y) = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldl $f)|] `appE` y
-                                            endo = iter' (d-1) [|fold|] hidEndo
-                                        in [| appEndo $endo $x|]
-                   body <- P.foldl conApp e vars
-                   return $ Clause [fp, ep, pat] (NormalB body) []
-            foldrClause (pat,vars) =
-                do fn <- newName "f"
-                   en <- newName "e"
-                   let f = varE fn
-                       e = varE en
-                       fp = if null vars then WildP else VarP fn
-                       ep = VarP en
-                       conApp (0,x) y = [|$f $x $y|]
-                       conApp (1,x) y = [|foldr $f $y $x |]
-                       conApp (d,x) y = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldr $f)|] `appE` x
-                                            endo = iter' (d-1) [|fold|] hidEndo
-                                        in [| appEndo $endo $y|]
-                   body <- P.foldr conApp e vars
-                   return $ Clause [fp, ep, pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Multi/Functor.hs b/src/Data/Comp/Derive/Multi/Functor.hs
deleted file mode 100644
--- a/src/Data/Comp/Derive/Multi/Functor.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Derive.Multi.Functor
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- Automatically derive instances of @HFunctor@.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Derive.Multi.Functor
-    (
-     HFunctor,
-     instanceHFunctor
-    ) where
-
-import Data.Comp.Derive.Utils
-import Data.Comp.Multi.Functor
-import Language.Haskell.TH
-import qualified Prelude as P (mapM)
-import Prelude hiding (mapM)
-import Data.Maybe
-import Control.Monad
-
-iter 0 _ e = e
-iter n f e = iter (n-1) f (f `appE` e)
-
-{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order
-  kind taking at least two arguments. -}
-instanceHFunctor :: Name -> Q [Dec]
-instanceHFunctor fname = do
-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
-  let args' = init args
-      fArg = VarT . tyVarBndrName $ last args'
-      argNames = (map (VarT . tyVarBndrName) (init args'))
-      complType = foldl AppT (ConT name) argNames
-      classType = AppT (ConT ''HFunctor) complType
-  constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
-  hfmapDecl <- funD 'hfmap (map hfmapClause constrs')
-  return [InstanceD [] classType [hfmapDecl]]
-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)
-            filterVar _ nonFarg [] x  = nonFarg x
-            filterVar farg _ [depth] x = farg depth x
-            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"
-            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs
-            mkCPat constr varNs = ConP constr $ map mkPat varNs
-            mkPat = VarP
-            mkPatAndVars (constr, args) =
-                do varNs <- newNames (length args) "x"
-                   return (conE constr, mkCPat constr varNs,
-                           \ f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),
-                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))
-            hfmapClause (con, pat,vars',hasFargs,_,_) =
-                do fn <- newName "f"
-                   let f = varE fn
-                       fp = if hasFargs then VarP fn else WildP
-                       vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id
-                   body <- foldl appE con vars
-                   return $ Clause [fp, pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Multi/Show.hs b/src/Data/Comp/Derive/Multi/Show.hs
deleted file mode 100644
--- a/src/Data/Comp/Derive/Multi/Show.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-# LANGUAGE TemplateHaskell, TypeOperators #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Derive.Multi.Show
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- Automatically derive instances of @HShowF@.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Derive.Multi.Show
-    (
-     HShowF(..),
-     KShow(..),
-     instanceHShowF
-    ) where
-
-import Data.Comp.Derive.Utils
-import Data.Comp.Multi.Functor
-import Data.Comp.Multi.Algebra
-import Language.Haskell.TH
-
-{-| Signature printing. An instance @HShowF f@ gives rise to an instance
-  @KShow (HTerm f)@. -}
-class HShowF f where
-    hshowF :: Alg f (K String)
-    hshowF = K . hshowF'
-    hshowF' :: f (K String) :=> String
-    hshowF' = unK . hshowF
-
-class KShow a where
-    kshow :: a i -> K String i
-
-showConstr :: String -> [String] -> String
-showConstr con [] = con
-showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"
-
-{-| Derive an instance of 'HShowF' for a type constructor of any higher-order
-  kind taking at least two arguments. -}
-instanceHShowF :: Name -> Q [Dec]
-instanceHShowF fname = do
-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
-  let args' = init args
-      fArg = VarT . tyVarBndrName $ last args'
-      argNames = (map (VarT . tyVarBndrName) (init args'))
-      complType = foldl AppT (ConT name) argNames
-      preCond = map (ClassP ''Show . (: [])) argNames
-      classType = AppT (ConT ''HShowF) complType
-  constrs' <- mapM normalConExp constrs
-  showFDecl <- funD 'hshowF (showFClauses fArg constrs')
-  return [InstanceD preCond classType [showFDecl]]
-      where showFClauses fArg = map (genShowFClause fArg)
-            filterFarg fArg ty x = (containsType ty fArg, varE x)
-            mkShow (isFArg, var)
-                | isFArg = [|unK $var|]
-                | otherwise = [| show $var |]
-            genShowFClause fArg (constr, args) = do 
-              let n = length args
-              varNs <- newNames n "x"
-              let pat = ConP constr $ map VarP varNs
-                  allVars = zipWith (filterFarg fArg) args varNs
-                  shows = listE $ map mkShow allVars
-                  conName = nameBase constr
-              body <- [|K $ showConstr conName $shows|]
-              return $ Clause [pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Multi/SmartConstructors.hs b/src/Data/Comp/Derive/Multi/SmartConstructors.hs
deleted file mode 100644
--- a/src/Data/Comp/Derive/Multi/SmartConstructors.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Derive.Multi.SmartConstructors
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- Automatically derive smart constructors for mutually recursive types.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Derive.Multi.SmartConstructors 
-    (smartHConstructors) where
-
-import Language.Haskell.TH hiding (Cxt)
-import Data.Comp.Derive.Utils
-import Data.Comp.Multi.Sum
-import Data.Comp.Multi.Term
-
-import Control.Monad
-
-{-| Derive smart constructors for a type constructor of any higher-order kind
- taking at least two arguments. The smart constructors are similar to the
- ordinary constructors, but an 'inject' is automatically inserted. -}
-smartHConstructors :: Name -> Q [Dec]
-smartHConstructors fname = do
-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
-    let cons = map abstractConType constrs
-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
-        where genSmartConstr targs tname (name, args) = do
-                let bname = nameBase name
-                genSmartConstr' targs tname (mkName $ 'i' : bname) name args
-              genSmartConstr' targs tname sname name args = do
-                varNs <- newNames args "x"
-                let pats = map varP varNs
-                    vars = map varE varNs
-                    val = foldl appE (conE name) vars
-                    sig = genSig targs tname sname args
-                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]
-                sequence $ sig ++ function
-              genSig targs tname sname 0 = (:[]) $ do
-                fvar <- newName "f"
-                hvar <- newName "h"
-                avar <- newName "a"
-                ivar <- newName "i"
-                let targs' = init $ init targs
-                    vars = fvar:hvar:avar:ivar:targs'
-                    f = varT fvar
-                    h = varT hvar
-                    a = varT avar
-                    i = varT ivar
-                    ftype = foldl appT (conT tname) (map varT targs')
-                    constr = classP ''(:<:) [ftype, f]
-                    typ = foldl appT (conT ''Cxt) [h, f, a, i]
-                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ
-                sigD sname typeSig
-              genSig _ _ _ _ = []
diff --git a/src/Data/Comp/Derive/Multi/Traversable.hs b/src/Data/Comp/Derive/Multi/Traversable.hs
deleted file mode 100644
--- a/src/Data/Comp/Derive/Multi/Traversable.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Derive.Multi.Traversable
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- Automatically derive instances of @HTraversable@.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Derive.Multi.Traversable
-    (
-     HTraversable,
-     instanceHTraversable
-    ) where
-
-import Data.Comp.Derive.Utils
-import Data.Comp.Multi.Traversable
-import Language.Haskell.TH
-import Data.Maybe
-import Data.Traversable
-import Data.Foldable hiding (any,or)
-import Control.Applicative
-import Control.Monad hiding (mapM, sequence)
-import qualified Prelude as P (foldl, foldr, mapM)
-import Prelude hiding  (foldl, foldr,mapM, sequence)
-
-iter 0 _ e = e
-iter n f e = iter (n-1) f (f `appE` e)
-
-iter' n f e = run n f e
-    where run 0 _ e = e
-          run m f e = let f' = iter (m-1) [|fmap|] f
-                        in run (m-1) f (f' `appE` e)
-
-{-| Derive an instance of 'HTraversable' for a type constructor of any
-  higher-order kind taking at least two arguments. -}
-instanceHTraversable :: Name -> Q [Dec]
-instanceHTraversable fname = do
-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
-  let args' = init args
-      fArg = VarT . tyVarBndrName $ last args'
-      argNames = (map (VarT . tyVarBndrName) (init args'))
-      complType = foldl AppT (ConT name) argNames
-      classType = AppT (ConT ''HTraversable) complType
-  constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
-  traverseDecl <- funD 'htraverse (map traverseClause constrs')
-  mapMDecl <- funD 'hmapM (map mapMClause constrs')
-  return [InstanceD [] classType [traverseDecl, mapMDecl]]
-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)
-            filterVar _ nonFarg [] x  = nonFarg x
-            filterVar farg _ [depth] x = farg depth x
-            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"
-            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs
-            mkCPat constr varNs = ConP constr $ map mkPat varNs
-            mkPat = VarP
-            mkPatAndVars (constr, args) =
-                do varNs <- newNames (length args) "x"
-                   return (conE constr, mkCPat constr varNs,
-                           \f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),
-                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))
-            traverseClause (con, pat,vars',hasFargs,_,_) =
-                do fn <- newName "f"
-                   let f = varE fn
-                       fp = if hasFargs then VarP fn else WildP
-                       vars = vars' (\d x -> iter d [|traverse|] f `appE` x) (\x -> [|pure $x|])
-                   body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars
-                   return $ Clause [fp, pat] (NormalB body) []
-            -- Note: the monadic versions are not defined
-            -- applicatively, as this results in a considerable
-            -- performance penalty (by factor 2)!
-            mapMClause (con, pat,_,hasFargs,allVars, fvars) =
-                do fn <- newName "f"
-                   let f = varE fn
-                       fp = if hasFargs then VarP fn else WildP
-                       conAp = P.foldl appE con allVars
-                       conBind (d,x) y = [| $(iter d [|mapM|] f) $(varE x)  >>= $(lamE [varP x] y)|]
-                   body <- P.foldr conBind [|return $conAp|] fvars
-                   return $ Clause [fp, pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Ordering.hs b/src/Data/Comp/Derive/Ordering.hs
--- a/src/Data/Comp/Derive/Ordering.hs
+++ b/src/Data/Comp/Derive/Ordering.hs
@@ -14,7 +14,7 @@
 module Data.Comp.Derive.Ordering
     (
      OrdF(..),
-     instanceOrdF
+     makeOrdF
     ) where
 
 import Data.Comp.Derive.Equality
@@ -35,8 +35,8 @@
 
 {-| Derive an instance of 'OrdF' for a type constructor of any first-order kind
   taking at least one argument. -}
-instanceOrdF :: Name -> Q [Dec]
-instanceOrdF fname = do
+makeOrdF :: Name -> Q [Dec]
+makeOrdF fname = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
   let argNames = (map (VarT . tyVarBndrName) (init args))
       complType = foldl AppT (ConT name) argNames
diff --git a/src/Data/Comp/Derive/Projections.hs b/src/Data/Comp/Derive/Projections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Projections.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE TemplateHaskell, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Projections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature projections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Projections
+    (
+     projn,
+     projectn,
+     deepProjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Control.Monad (liftM)
+import Data.Traversable (Traversable)
+import Data.Comp.Term
+import Data.Comp.Algebra (CxtFunM, appSigFunM')
+import Data.Comp.Ops ((:+:)(..), (:<:)(..))
+
+projn :: Int -> Q [Dec]
+projn n = do
+  let p = mkName $ "proj" ++ show n
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar) []]]
+  sequence $ (sigD p $ genSig gvars avar) : d
+    where genSig gvars avar = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = arrowT `appT` (varT fvar `appT` varT avar)
+                             `appT` (conT ''Maybe `appT`
+                                     (tp `appT` varT avar))
+            forallT (map PlainTV $ fvar : avar : gvars) (sequence cxt) tp'
+          genDecl x [g] a =
+            [| liftM inj (proj $(varE x)
+                          :: Maybe ($(varT g `appT` varT a))) |]
+          genDecl x (g:gs) a =
+            [| case (proj $(varE x)
+                         :: Maybe ($(varT g `appT` varT a))) of
+                 Just y -> Just $ inj y
+                 _ -> $(genDecl x gs a) |]
+          genDecl _ _ _ = error "genDecl called with empty list"
+
+projectn :: Int -> Q [Dec]
+projectn n = do
+  let p = mkName ("project" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD p $ genSig gvars avar) : d
+    where genSig gvars avar = do
+            let fvar = mkName "f"
+            let hvar = mkName "h"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar
+                                 `appT` varT avar
+            let tp'' = arrowT `appT` tp'
+                              `appT` (conT ''Maybe `appT` (tp `appT` tp'))
+            forallT (map PlainTV $ hvar : fvar : avar : gvars)
+                    (sequence cxt) tp''
+          genDecl x n = [| case $(varE x) of
+                             Hole _ -> Nothing
+                             Term t -> $(varE $ mkName $ "proj" ++ show n) t |]
+
+deepProjectn :: Int -> Q [Dec]
+deepProjectn n = do
+  let p = mkName ("deepProject" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let d = [funD p [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD p $ genSig gvars) : d
+    where genSig gvars = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let cxt' = classP ''Traversable [tp]
+            let tp' = conT ''CxtFunM `appT` conT ''Maybe
+                                     `appT` varT fvar `appT` tp
+            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
diff --git a/src/Data/Comp/Derive/Show.hs b/src/Data/Comp/Derive/Show.hs
--- a/src/Data/Comp/Derive/Show.hs
+++ b/src/Data/Comp/Derive/Show.hs
@@ -15,7 +15,7 @@
 module Data.Comp.Derive.Show
     (
      ShowF(..),
-     instanceShowF
+     makeShowF
     ) where
 
 import Data.Comp.Derive.Utils
@@ -32,8 +32,8 @@
 
 {-| Derive an instance of 'ShowF' for a type constructor of any first-order kind
   taking at least one argument. -}
-instanceShowF :: Name -> Q [Dec]
-instanceShowF fname = do
+makeShowF :: Name -> Q [Dec]
+makeShowF fname = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
   let fArg = VarT . tyVarBndrName $ last args
       argNames = (map (VarT . tyVarBndrName) (init args))
diff --git a/src/Data/Comp/Derive/SmartAConstructors.hs b/src/Data/Comp/Derive/SmartAConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/SmartAConstructors.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.SmartAConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors with annotations.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.SmartAConstructors
+    (
+     smartAConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Sum
+import Data.Comp.Term
+import Data.Comp.Annotation
+import Control.Monad
+
+{-| Derive smart constructors with products for a type constructor of any
+  parametric kind taking at least one argument. The smart constructors are
+  similar to the ordinary constructors, but an 'injectA' is automatically
+  inserted. -}
+smartAConstructors :: Name -> Q [Dec]
+smartAConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let cons = map abstractConType constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where genSmartConstr targs tname (name, args) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args
+              genSmartConstr' targs tname sname name args = do
+                varNs <- newNames args "x"
+                varPr <- newName "_p"
+                let pats = map varP (varPr : varNs)
+                    vars = map varE varNs
+                    val = appE [|injectA $(varE varPr)|] $
+                          appE [|inj|] $ foldl appE (conE name) vars
+                    function = [funD sname [clause pats (normalB [|Term $val|]) []]]
+                sequence function
diff --git a/src/Data/Comp/Derive/SmartConstructors.hs b/src/Data/Comp/Derive/SmartConstructors.hs
--- a/src/Data/Comp/Derive/SmartConstructors.hs
+++ b/src/Data/Comp/Derive/SmartConstructors.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Derive.Signature
@@ -14,15 +13,14 @@
 --------------------------------------------------------------------------------
 
 module Data.Comp.Derive.SmartConstructors 
-    (smartConstructors) where
-
-
+    (
+     smartConstructors
+    ) where
 
 import Language.Haskell.TH hiding (Cxt)
 import Data.Comp.Derive.Utils
 import Data.Comp.Sum
 import Data.Comp.Term
-
 import Control.Monad
 
 {-| Derive smart constructors for a type constructor of any first-order kind
diff --git a/src/Data/Comp/Derive/Traversable.hs b/src/Data/Comp/Derive/Traversable.hs
--- a/src/Data/Comp/Derive/Traversable.hs
+++ b/src/Data/Comp/Derive/Traversable.hs
@@ -15,7 +15,7 @@
 module Data.Comp.Derive.Traversable
     (
      Traversable,
-     instanceTraversable
+     makeTraversable
     ) where
 
 import Data.Comp.Derive.Utils
@@ -38,8 +38,8 @@
 
 {-| Derive an instance of 'Traversable' for a type constructor of any
   first-order kind taking at least one argument. -}
-instanceTraversable :: Name -> Q [Dec]
-instanceTraversable fname = do
+makeTraversable :: Name -> Q [Dec]
+makeTraversable fname = do
   TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
   let fArg = VarT . tyVarBndrName $ last args
       argNames = (map (VarT . tyVarBndrName) (init args))
diff --git a/src/Data/Comp/Derive/Utils.hs b/src/Data/Comp/Derive/Utils.hs
--- a/src/Data/Comp/Derive/Utils.hs
+++ b/src/Data/Comp/Derive/Utils.hs
@@ -99,3 +99,12 @@
 
 tupleTypes n m = map tupleTypeName [n..m]
 
+{-| Helper function for generating a list of instances for a list of named
+ signatures. For example, in order to derive instances 'Functor' and
+ 'ShowF' for a signature @Exp@, use derive as follows (requires Template
+ Haskell):
+
+ > $(derive [makeFunctor, makeShowF] [''Exp])
+ -}
+derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
+derive ders names = liftM concat $ sequence [der name | der <- ders, name <- names]
diff --git a/src/Data/Comp/Desugar.hs b/src/Data/Comp/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Desugar.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Desugar
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This modules defines the 'Desugar' type class for desugaring of terms.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Desugar where
+
+import Data.Comp
+import Data.Comp.Derive
+
+-- |The desugaring term homomorphism.
+class (Functor f, Functor g) => Desugar f g where
+    desugHom :: TermHom f g
+    desugHom = desugHom' . fmap Hole
+    desugHom' :: Alg f (Context g a)
+    desugHom' x = appCxt (desugHom x)
+
+$(derive [liftSum] [''Desugar])
+
+-- |Desugar a term.
+desugar :: Desugar f g => Term f -> Term g
+{-# INLINE desugar #-}
+desugar = appTermHom desugHom
+
+-- |Lift desugaring to annotated terms.
+desugarA :: (Functor f', Functor g', DistAnn f p f', DistAnn g p g',
+             Desugar f g) => Term f' -> Term g'
+desugarA = appTermHom (propAnn desugHom)
+
+-- |Default desugaring instance.
+instance (Functor f, Functor g, f :<: g) => Desugar f g where
+    desugHom = simpCxt . inj
diff --git a/src/Data/Comp/Equality.hs b/src/Data/Comp/Equality.hs
--- a/src/Data/Comp/Equality.hs
+++ b/src/Data/Comp/Equality.hs
@@ -20,6 +20,7 @@
 
 import Data.Comp.Term
 import Data.Comp.Sum
+import Data.Comp.Ops
 import Data.Comp.Derive
 import Data.Comp.Derive.Utils
 
@@ -72,4 +73,4 @@
           unit' = fmap (const ())
           args = toList s `zip` toList t
 
-$(derive [instanceEqF] $ (''Maybe) : tupleTypes 2 10)
+$(derive [makeEqF] $ (''Maybe) : tupleTypes 2 10)
diff --git a/src/Data/Comp/Multi.hs b/src/Data/Comp/Multi.hs
--- a/src/Data/Comp/Multi.hs
+++ b/src/Data/Comp/Multi.hs
@@ -3,55 +3,48 @@
 -- Module      :  Data.Comp.Multi
 -- Copyright   :  (c) 2011 Patrick Bahr
 -- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>
 -- Stability   :  experimental
 -- Portability :  non-portable (GHC Extensions)
 --
--- This module defines the infrastructure necessary to use compositional data
--- types for mutually recursive data types. Examples of usage are provided
--- below.
+-- This module defines the infrastructure necessary to use
+-- /Generalised Compositional Data Types/. Generalised Compositional Data Types 
+-- is an extension of Compositional Data Types with mutually recursive
+-- data types, and more generally GADTs. Examples of usage are bundled with the
+-- package in the library @examples\/Examples\/Multi@.
 --
 --------------------------------------------------------------------------------
 module Data.Comp.Multi (
-  -- * Examples
-  -- ** Pure Computations
-  -- $ex1
-
-  -- ** Monadic Computations
-  -- $ex2
-
-  -- ** Composing Term Homomorphisms and Algebras
-  -- $ex3
-
-  -- ** Lifting Term Homomorphisms to Products
-  -- $ex4
     module Data.Comp.Multi.Term
-  , module Data.Comp.Multi.Algebra
   , module Data.Comp.Multi.Functor
+  , module Data.Comp.Multi.Algebra
   , module Data.Comp.Multi.Sum
-  , module Data.Comp.Multi.Product
+  , module Data.Comp.Multi.Annotation
+  , module Data.Comp.Multi.Equality
+  , module Data.Comp.Multi.Generic
     ) where
 
+import Data.Comp.Multi.Functor
 import Data.Comp.Multi.Term
 import Data.Comp.Multi.Algebra
-import Data.Comp.Multi.Functor
 import Data.Comp.Multi.Sum
-import Data.Comp.Multi.Product
+import Data.Comp.Multi.Annotation
+import Data.Comp.Multi.Equality
+import Data.Comp.Multi.Generic
 
 {- $ex1
-The example below illustrates how to use generalised compositional data types 
+The example illustrates how to use generalised compositional data types 
 to implement a small expression language, with a sub language of values, and 
 an evaluation function mapping expressions to values.
 
-The following language extensions are
-needed in order to run the example: @TemplateHaskell@, @TypeOperators@,
-@MultiParamTypeClasses@, @FlexibleInstances@, @FlexibleContexts@,
-@UndecidableInstances@, and @GADTs@. Moreover, in order to derive instances for
-GADTs, version 7 of GHC is needed.
+The following language extensions are needed in order to run the example:
+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,
+@GADTs@. Besides, GCH 7 is required.
 
 > import Data.Comp.Multi
 > import Data.Comp.Multi.Show ()
-> import Data.Comp.Derive
+> import Data.Comp.Multi.Derive
 > 
 > -- Signature for values and operators
 > data Value e l where
@@ -61,17 +54,17 @@
 >   Add, Mult  :: e Int -> e Int   -> Op e Int
 >   Fst        ::          e (s,t) -> Op e s
 >   Snd        ::          e (s,t) -> Op e t
->
+> 
 > -- Signature for the simple expression language
 > type Sig = Op :+: Value
 > 
 > -- Derive boilerplate code using Template Haskell (GHC 7 needed)
-> $(derive [instanceHFunctor, instanceHShowF, smartHConstructors] 
+> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] 
 >          [''Value, ''Op])
 > 
 > -- Term evaluation algebra
 > class Eval f v where
->   evalAlg :: Alg f (HTerm v)
+>   evalAlg :: Alg f (Term v)
 > 
 > instance (Eval f v, Eval g v) => Eval (f :+: g) v where
 >   evalAlg (Inl x) = evalAlg x
@@ -102,19 +95,18 @@
 -}
 
 {- $ex2
-The example below illustrates how to use generalised compositional data types to
+The example illustrates how to use generalised compositional data types to
 implement a small expression language, with a sub language of values, and a 
 monadic evaluation function mapping expressions to values.
 
-The following language
-extensions are needed in order to run the example: @TemplateHaskell@,
-@TypeOperators@, @MultiParamTypeClasses@, @FlexibleInstances@,
-@FlexibleContexts@, @UndecidableInstances@, and @GADTs@.  Moreover, in order to
-derive instances for GADTs, version 7 of GHC is needed.
+The following language extensions are needed in order to run the example:
+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,
+@GADTs@. Besides, GCH 7 is required.
 
 > import Data.Comp.Multi
 > import Data.Comp.Multi.Show ()
-> import Data.Comp.Derive
+> import Data.Comp.Multi.Derive
 > import Control.Monad (liftM)
 > 
 > -- Signature for values and operators
@@ -130,8 +122,8 @@
 > type Sig = Op :+: Value
 > 
 > -- Derive boilerplate code using Template Haskell (GHC 7 needed)
-> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,
->           instanceHEqF, instanceHShowF, smartHConstructors]
+> $(derive [makeHFunctor, makeHTraversable, makeHFoldable,
+>           makeHEqF, makeHShowF, smartConstructors]
 >          [''Value, ''Op])
 > 
 > -- Monadic term evaluation algebra
@@ -142,8 +134,7 @@
 >   evalAlgM (Inl x) = evalAlgM x
 >   evalAlgM (Inr x) = evalAlgM x
 > 
-> evalM :: (HTraversable f, EvalM f v) => Term f l
->                                      -> Maybe (Term v l)
+> evalM :: (HTraversable f, EvalM f v) => Term f l -> Maybe (Term v l)
 > evalM = cataM evalAlgM
 > 
 > instance (Value :<: v) => EvalM Value v where
@@ -174,17 +165,74 @@
 -}
 
 {- $ex3
-The example below illustrates how to compose a term homomorphism and an algebra,
+The example illustrates how to use generalised compositional data types 
+to implement a small expression language, and  an evaluation function mapping
+intrinsically typed expressions to values.
+
+The following language extensions are needed in order to run the example:
+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,
+@GADTs@. Besides, GCH 7 is required.
+
+> import Data.Comp.Multi
+> import Data.Comp.Multi.Show ()
+> import Data.Comp.Multi.Derive
+> 
+> -- Signature for values and operators
+> data Value e l where
+>   Const  ::        Int -> Value e Int
+>   Pair   :: e s -> e t -> Value e (s,t)
+> data Op e l where
+>   Add, Mult  :: e Int -> e Int   -> Op e Int
+>   Fst        ::          e (s,t) -> Op e s
+>   Snd        ::          e (s,t) -> Op e t
+> 
+> -- Signature for the simple expression language
+> type Sig = Op :+: Value
+> 
+> -- Derive boilerplate code using Template Haskell (GHC 7 needed)
+> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] 
+>          [''Value, ''Op])
+> 
+> -- Term evaluation algebra
+> class EvalI f where
+>   evalAlgI :: Alg f I
+> 
+> instance (EvalI f, EvalI g) => EvalI (f :+: g) where
+>   evalAlgI (Inl x) = evalAlgI x
+>   evalAlgI (Inr x) = evalAlgI x
+> 
+> -- Lift the evaluation algebra to a catamorphism
+> evalI :: (HFunctor f, EvalI f) => Term f i -> i
+> evalI = unI . cata evalAlgI
+> 
+> instance EvalI Value where
+>   evalAlgI (Const n) = I n
+>   evalAlgI (Pair (I x) (I y)) = I (x,y)
+> 
+> instance EvalI Op where
+>   evalAlgI (Add (I x) (I y))  = I (x + y)
+>   evalAlgI (Mult (I x) (I y)) = I (x * y)
+>   evalAlgI (Fst (I (x,_)))    = I x
+>   evalAlgI (Snd (I (_,y)))    = I y
+> 
+> -- Example: evalEx = 2
+> evalIEx :: Int
+> evalIEx = evalI (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int)
+-}
+
+{- $ex4
+The example illustrates how to compose a term homomorphism and an algebra,
 exemplified via a desugaring term homomorphism and an evaluation algebra.
 
 The following language extensions are needed in order to run the example:
 @TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
-@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@. 
-Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.
+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,
+@GADTs@. Besides, GCH 7 is required.
 
 > import Data.Comp.Multi
 > import Data.Comp.Multi.Show ()
-> import Data.Comp.Derive
+> import Data.Comp.Multi.Derive
 > 
 > -- Signature for values, operators, and syntactic sugar
 > data Value e l where
@@ -197,7 +245,7 @@
 > data Sugar e l where
 >   Neg   :: e Int   -> Sugar e Int
 >   Swap  :: e (s,t) -> Sugar e (t,s)
->
+> 
 > -- Source position information (line number, column number)
 > data Pos = Pos Int Int
 >            deriving Show
@@ -205,14 +253,14 @@
 > -- Signature for the simple expression language
 > type Sig = Op :+: Value
 > type SigP = Op :&: Pos :+: Value :&: Pos
->
+> 
 > -- Signature for the simple expression language, extended with syntactic sugar
 > type Sig' = Sugar :+: Op :+: Value
 > type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
 > 
 > -- Derive boilerplate code using Template Haskell (GHC 7 needed)
-> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,
->           instanceHEqF, instanceHShowF, smartHConstructors]
+> $(derive [makeHFunctor, makeHTraversable, makeHFoldable,
+>           makeHEqF, makeHShowF, smartConstructors]
 >          [''Value, ''Op, ''Sugar])
 > 
 > -- Term homomorphism for desugaring of terms
@@ -237,7 +285,7 @@
 > instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where
 >   desugHom' (Neg x)  = iConst (-1) `iMult` x
 >   desugHom' (Swap x) = iSnd x `iPair` iFst x
->
+> 
 > -- Term evaluation algebra
 > class Eval f v where
 >   evalAlg :: Alg f (Term v)
@@ -254,13 +302,13 @@
 >   evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
 >   evalAlg (Fst x)    = fst $ projP x
 >   evalAlg (Snd x)    = snd $ projP x
->
+> 
 > projC :: (Value :<: v) => Term v Int -> Int
 > projC v = case project v of Just (Const n) -> n
->
-> projP :: (Value :<: v) => HTerm v (s,t) -> (HTerm v s, HTerm v t)
+> 
+> projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t)
 > projP v = case project v of Just (Pair x y) -> (x,y)
->
+> 
 > -- Compose the evaluation algebra and the desugaring homomorphism to an
 > -- algebra
 > eval :: Term Sig' :-> Term Value
@@ -271,19 +319,19 @@
 > evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)
 -}
 
-{- $ex4
-The example below illustrates how to lift a term homomorphism to products,
+{- $ex5
+The example illustrates how to lift a term homomorphism to annotations,
 exemplified via a desugaring term homomorphism lifted to terms annotated with
 source position information.
 
 The following language extensions are needed in order to run the example:
 @TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
-@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@.
- Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.
+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,
+@GADTs@. Besides, GCH 7 is required.
 
 > import Data.Comp.Multi
 > import Data.Comp.Multi.Show ()
-> import Data.Comp.Derive
+> import Data.Comp.Multi.Derive
 > 
 > -- Signature for values, operators, and syntactic sugar
 > data Value e l where
@@ -296,22 +344,22 @@
 > data Sugar e l where
 >   Neg   :: e Int   -> Sugar e Int
 >   Swap  :: e (s,t) -> Sugar e (t,s)
->
+> 
 > -- Source position information (line number, column number)
 > data Pos = Pos Int Int
->            deriving Show
+>            deriving (Show, Eq)
 > 
 > -- Signature for the simple expression language
 > type Sig = Op :+: Value
 > type SigP = Op :&: Pos :+: Value :&: Pos
->
+> 
 > -- Signature for the simple expression language, extended with syntactic sugar
 > type Sig' = Sugar :+: Op :+: Value
 > type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos
 > 
 > -- Derive boilerplate code using Template Haskell (GHC 7 needed)
-> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,
->           instanceHEqF, instanceHShowF, smartHConstructors]
+> $(derive [makeHFunctor, makeHTraversable, makeHFoldable,
+>           makeHEqF, makeHShowF, smartConstructors]
 >          [''Value, ''Op, ''Sugar])
 > 
 > -- Term homomorphism for desugaring of terms
@@ -336,34 +384,34 @@
 > instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where
 >   desugHom' (Neg x)  = iConst (-1) `iMult` x
 >   desugHom' (Swap x) = iSnd x `iPair` iFst x
->
+> 
 > -- Lift the desugaring term homomorphism to a catamorphism
 > desug :: Term Sig' :-> Term Sig
 > desug = appTermHom desugHom
->
+> 
 > -- Example: desugEx = iPair (iConst 2) (iConst 1)
 > desugEx :: Term Sig (Int,Int)
 > desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)
->
+> 
 > -- Lift desugaring to terms annotated with source positions
 > desugP :: Term SigP' :-> Term SigP
-> desugP = appTermHom (productTermHom desugHom)
->
-> iSwapP :: (DistProd f p f', Sugar :<: f) => p -> Term f' (a,b) -> Term f' (b,a)
-> iSwapP p x = Term (injectP p $ inj $ Swap x)
->
-> iConstP :: (DistProd f p f', Value :<: f) => p -> Int -> Term f' Int
-> iConstP p x = Term (injectP p $ inj $ Const x)
->
-> iPairP :: (DistProd f p f', Value :<: f) => p -> Term f' a -> Term f' b -> Term f' (a,b)
-> iPairP p x y = Term (injectP p $ inj $ Pair x y)
->
-> iFstP :: (DistProd f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' a
-> iFstP p x = Term (injectP p $ inj $ Fst x)
->
-> iSndP :: (DistProd f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' b
-> iSndP p x = Term (injectP p $ inj $ Snd x)
->
+> desugP = appTermHom (propAnn desugHom)
+> 
+> iSwapP :: (DistAnn f p f', Sugar :<: f) => p -> Term f' (a,b) -> Term f' (b,a)
+> iSwapP p x = Term (injectA p $ inj $ Swap x)
+> 
+> iConstP :: (DistAnn f p f', Value :<: f) => p -> Int -> Term f' Int
+> iConstP p x = Term (injectA p $ inj $ Const x)
+> 
+> iPairP :: (DistAnn f p f', Value :<: f) => p -> Term f' a -> Term f' b -> Term f' (a,b)
+> iPairP p x y = Term (injectA p $ inj $ Pair x y)
+> 
+> iFstP :: (DistAnn f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' a
+> iFstP p x = Term (injectA p $ inj $ Fst x)
+> 
+> iSndP :: (DistAnn f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' b
+> iSndP p x = Term (injectA p $ inj $ Snd x)
+> 
 > -- Example: desugPEx = iPairP (Pos 1 0)
 > --                            (iSndP (Pos 1 0) (iPairP (Pos 1 1)
 > --                                                     (iConstP (Pos 1 2) 1)
@@ -374,80 +422,4 @@
 > desugPEx :: Term SigP (Int,Int)
 > desugPEx = desugP $ iSwapP (Pos 1 0) (iPairP (Pos 1 1) (iConstP (Pos 1 2) 1)
 >                                                        (iConstP (Pos 1 3) 2))
--}
-
-{- $ex5
-The example below illustrates how to use Higher-Order Abstract Syntax (HOAS)
-with generalised compositional data types.
-
-The following language extensions are needed in order to run the example:
-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,
-@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@.
-Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.
-
-> import Data.Comp.Multi
-> import Data.Comp.Derive
-> 
-> data Value e l where
->   Const  ::        Int -> Value e Int
->   Pair   :: e s -> e t -> Value e (s,t)
-> data Op e l where
->   Add, Mult  :: e Int -> e Int   -> Op e Int
->   Fst        ::          e (s,t) -> Op e s
->   Snd        ::          e (s,t) -> Op e t
-> data Lam e l where
->   Lam :: (e l1 -> e l2) -> Lam e (l1 -> l2)
-> data App e l where
->   App :: e (l1 -> l2) -> e l1 -> App e l2
->
-> -- Signature for values
-> type Val = Lam :++: Value
->
-> -- Signature for expressions
-> type Sig = App :++: Op :++: Val
-> 
-> -- Derive boilerplate code using Template Haskell (GHC 7 needed)
-> $(derive [instanceHExpFunctor, smartHConstructors] 
->          [''Value, ''Op, ''Lam, ''App])
-> 
-> -- Term evaluation algebra
-> class Eval f v where
->   evalAlg :: HAlg f (HTerm v)
-> 
-> instance (Eval f v, Eval g v) => Eval (f :++: g) v where
->   evalAlg (HInl x) = evalAlg x
->   evalAlg (HInr x) = evalAlg x
-> 
-> -- Lift the evaluation algebra to a catamorphism
-> evalE :: (HExpFunctor f, Eval f v) => HTerm f :-> HTerm v
-> evalE = hcataE evalAlg
-> 
-> instance (Value :<<: v) => Eval Value v where
->   evalAlg = hinject
-> 
-> instance (Value :<<: v) => Eval Op v where
->   evalAlg (Add x y)  = iConst $ (projC x) + (projC y)
->   evalAlg (Mult x y) = iConst $ (projC x) * (projC y)
->   evalAlg (Fst x)    = fst $ projP x
->   evalAlg (Snd x)    = snd $ projP x
->
-> instance (Lam :<<: v) => Eval Lam v where
->   evalAlg = hinject
->
-> instance (Lam :<<: v) => Eval App v where
->   evalAlg (App x y) = (projL x) y
->
-> projC :: (Value :<<: v) => HTerm v Int -> Int
-> projC v = case hproject v of Just (Const n) -> n
-> 
-> projP :: (Value :<<: v) => HTerm v (s,t) -> (HTerm v s, HTerm v t)
-> projP v = case hproject v of Just (Pair x y) -> (x,y)
->
-> projL :: (Lam :<<: v) => HTerm v (l1 -> l2) -> HTerm v l1 -> HTerm v l2
-> projL v = case hproject v of Just (Lam f) -> f
-> 
-> -- Example: evalEEx = iConst 3
-> evalEEx :: HTerm Val Int
-> evalEEx = evalE (((iLam $ \x -> x) `iApp`
->                   (iConst 1 `iAdd` iConst 2)) :: HTerm Sig Int)
 -}
diff --git a/src/Data/Comp/Multi/Algebra.hs b/src/Data/Comp/Multi/Algebra.hs
--- a/src/Data/Comp/Multi/Algebra.hs
+++ b/src/Data/Comp/Multi/Algebra.hs
@@ -25,7 +25,6 @@
       
       -- * Monadic Algebras & Catamorphisms
       AlgM,
---      halgM,
       freeM,
       cataM,
       cataM',
@@ -36,27 +35,25 @@
       SigFun,
       TermHom,
       appTermHom,
+      appTermHom',
       compTermHom,
       appSigFun,
+      appSigFun',
       compSigFun,
       termHom,
       compAlg,
---      compCoalg,
---      compCVCoalg,
 
       -- * Monadic Term Homomorphisms
       CxtFunM,
       SigFunM,
       TermHomM,
---      SigFunM',
---      TermHomM',
       sigFunM,
---      termHom',
+      termHom',
       appTermHomM,
+      appTermHomM',
       termHomM,
---      termHomM',
       appSigFunM,
---      appSigFunM',
+      appSigFunM',
       compTermHomM,
       compSigFunM,
       compAlgM,
@@ -65,7 +62,6 @@
       -- * Coalgebras & Anamorphisms
       Coalg,
       ana,
---      ana',
       CoalgM,
       anaM,
 
@@ -81,18 +77,10 @@
       RCoalgM,
       apoM,
 
-      -- * CV-Algebras & Histomorphisms
-      -- $l1
---      CVAlg,
---      histo,
---      CVAlgM,
---      histoM,
 
       -- * CV-Coalgebras & Futumorphisms
       CVCoalg,
       futu,
---      CVCoalg',
---      futu',
       CVCoalgM,
       futuM,
     ) where
@@ -104,9 +92,12 @@
 import Data.Comp.Ops
 import Control.Monad
 
-
+-- | This type represents multisorted @f@-algebras with a family @e@
+-- of carriers.
 type Alg f e = f e :-> e
 
+-- | Construct a catamorphism for contexts over @f@ with holes of type
+-- @b@, from the given algebra.
 free :: forall f h a b . (HFunctor f) =>
               Alg f b -> (a :-> b) -> Cxt h f a :-> b
 free f g = run
@@ -114,17 +105,18 @@
           run (Hole v) = g v
           run (Term c) = f $ hfmap run c
 
-
+-- | Construct a catamorphism from the given algebra.
 cata :: forall f a. HFunctor f => Alg f a -> Term f :-> a
 cata f = run 
     where run :: Term f :-> a
           run (Term t) = f (hfmap run t)
 
+-- | A generalisation of 'cata' from terms over @f@ to contexts over
+-- @f@, where the holes have the type of the algebra carrier.
 cata' :: HFunctor f => Alg f e -> Cxt h f e :-> e
 cata' alg = free alg id
 
 -- | This function applies a whole context into another context.
-
 appCxt :: HFunctor f => Context f (Cxt h f a) :-> Cxt h f a
 appCxt = cata' Term
 
@@ -137,9 +129,12 @@
                      return $ I x
           turn x = do I y <- x
                       return y
-
+-- | This type represents a monadic algebra. It is similar to 'Alg'
+-- but the return type is monadic.
 type AlgM m f e = NatM m (f e) e
 
+-- | Construct a monadic catamorphism for contexts over @f@ with holes
+-- of type @b@, from the given monadic algebra.
 freeM :: forall f m h a b. (HTraversable f, Monad m) =>
                AlgM m f b -> NatM m a b -> NatM m (Cxt h f a)  b
 freeM algm var = run
@@ -148,47 +143,52 @@
           run (Term x) = hmapM run x >>= algm
 
 -- | This is a monadic version of 'cata'.
-
 cataM :: forall f m a. (HTraversable f, Monad m) =>
          AlgM m f a -> NatM m (Term f) a
--- cataM alg h (Term t) = alg =<< hmapM (cataM alg h) t
 cataM alg = run
     where run :: NatM m (Term f) a
           run (Term x) = alg =<< hmapM run x
+-- cataM alg h (Term t) = alg =<< hmapM (cataM alg h) t
 
 
 cataM' :: forall m h a f. (Monad m, HTraversable f) => AlgM m f a -> NatM m (Cxt h f a) a
--- cataM' alg = freeM alg return
 cataM' f = run
     where run :: NatM m (Cxt h f a) a
           run (Hole x) = return x
           run (Term x) = hmapM run x >>= f
+-- cataM' alg = freeM alg return
 
--- | This type represents context function.
 
-type CxtFun f g = forall a h. Cxt h f a :-> Cxt h g a
-
 -- | This type represents uniform signature function specification.
-
 type SigFun f g = forall a. f a :-> g a
 
-
--- | This type represents a term algebra.
+-- | This type represents context function.
+type CxtFun f g = forall h . SigFun (Cxt h f) (Cxt h g)
 
+-- | This type represents term homomorphisms.
 type TermHom f g = SigFun f (Context g)
 
 -- | This function applies the given term homomorphism to a
 -- term/context.
-
-appTermHom :: (HFunctor f, HFunctor g) => TermHom f g -> CxtFun f g
+appTermHom :: forall f g . (HFunctor f, HFunctor g) => TermHom f g -> CxtFun f g
 -- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type
 -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b
 -- would achieve the same. The given type is chosen for clarity.
-appTermHom _ (Hole b) = Hole b
-appTermHom f (Term t) = appCxt . f . hfmap (appTermHom f) $ t
+appTermHom f = run where
+    run :: CxtFun f g
+    run (Hole b) = Hole b
+    run (Term t) = appCxt . f . hfmap run $ t
 
--- | This function composes two term algebras.
 
+-- | This function applies the given term homomorphism to a
+-- term/context. This is the top-down variant of 'appTermHom'.
+appTermHom' :: forall f g . (HFunctor g) => TermHom f g -> CxtFun f g
+appTermHom' f = run where
+    run :: CxtFun f g
+    run (Hole b) = Hole b
+    run (Term t) = appCxt . hfmap run . f $ t
+
+-- | This function composes two term algebras.
 compTermHom :: (HFunctor g, HFunctor h) => TermHom g h -> TermHom f g -> TermHom f h
 -- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type
 -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b))
@@ -197,52 +197,53 @@
 compTermHom f g = appTermHom f . g
 
 -- | This function composes a term algebra with an algebra.
-
 compAlg :: (HFunctor g) => Alg g a -> TermHom f g -> Alg f a
 compAlg alg talg = cata' alg . talg
 
--- | This function applies a signature function to the given context.
+-- | This function applies a signature function to the given
+-- context. This is the top-down variant of 'appSigFun'.
+appSigFun' :: forall f g. (HFunctor g) => SigFun f g -> CxtFun f g
+appSigFun' f = run
+    where run :: CxtFun f g
+          run (Hole b) = Hole b
+          run (Term t) = Term . hfmap run . f $ t
 
-appSigFun :: (HFunctor f, HFunctor g) => SigFun f g -> CxtFun f g
-appSigFun f = appTermHom $ termHom f
+-- | This function applies a signature function to the given context.
+appSigFun :: forall f g. (HFunctor f) => SigFun f g -> CxtFun f g
+appSigFun f = run
+    where run :: CxtFun f g
+          run (Hole b) = Hole b
+          run (Term t) = Term . f . hfmap run $ t
 
 
 -- | This function composes two signature functions.
-
 compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
 compSigFun f g = f . g
 
-
-
-
 -- | Lifts the given signature function to the canonical term homomorphism.
 termHom :: (HFunctor g) => SigFun f g -> TermHom f g
 termHom f = simpCxt . f
 
--- | This type represents monadic context function.
-
-type CxtFunM m f g = forall a h. NatM m (Cxt h f a) (Cxt h g a)
-
 -- | This type represents monadic signature functions.
-
 type SigFunM m f g = forall a. NatM m (f a) (g a)
 
 
--- | This type represents monadic term algebras.
+-- | This type represents monadic context function.
+type CxtFunM m f g = forall h. SigFunM m (Cxt h f) (Cxt h g)
 
+
+-- | This type represents monadic term algebras.
 type TermHomM m f g = SigFunM m f (Context g)
 
 -- | This function lifts the given signature function to a monadic
 -- signature function. Note that term algebras are instances of
 -- signature functions. Hence this function also applies to term
 -- algebras.
-
 sigFunM :: (Monad m) => SigFun f g -> SigFunM m f g
 sigFunM f = return . f
 
 -- | This function lifts the give monadic signature function to a
 -- monadic term algebra.
-
 termHom' :: (HFunctor f, HFunctor g, Monad m) =>
             SigFunM m f g -> TermHomM m f g
 termHom' f = liftM  (Term . hfmap Hole) . f
@@ -259,17 +260,39 @@
 appTermHomM :: forall f g m . (HTraversable f, HFunctor g, Monad m)
          => TermHomM m f g -> CxtFunM m f g
 appTermHomM f = run
-    where run :: NatM m (Cxt h f a) (Cxt h g a)
+    where run :: CxtFunM m f g
           run (Hole b) = return $ Hole b
           run (Term t) = liftM appCxt . (>>= f) . hmapM run $ t
 
+-- | This function applies the given monadic term homomorphism to the
+-- given term/context. This is a top-down variant of 'appTermHomM'.
+
+appTermHomM' :: forall f g m . (HTraversable g, Monad m)
+         => TermHomM m f g -> CxtFunM m f g
+appTermHomM' f = run
+    where run :: CxtFunM m f g
+          run (Hole b) = return $ Hole b
+          run (Term t) = liftM appCxt . hmapM run =<< f t
+
 -- | This function applies the given monadic signature function to the
 -- given context.
 
-appSigFunM :: (HTraversable f, HFunctor g, Monad m) =>
+appSigFunM :: forall f g m. (HTraversable f, Monad m) =>
                 SigFunM m f g -> CxtFunM m f g
-appSigFunM f = appTermHomM $ termHom' f
+appSigFunM f = run
+    where run :: CxtFunM m f g
+          run (Hole b) = return $ Hole b
+          run (Term t) = liftM Term . f =<< hmapM run t
 
+-- | This function applies the given monadic signature function to the
+-- given context. This is a top-down variant of 'appSigFunM'.
+appSigFunM' :: forall f g m. (HTraversable g, Monad m) =>
+                SigFunM m f g -> CxtFunM m f g
+appSigFunM' f = run
+    where run :: CxtFunM m f g
+          run (Hole b) = return $ Hole b
+          run (Term t) = liftM Term . hmapM run =<< f t
+
 -- | This function composes two monadic term algebras.
 
 compTermHomM :: (HTraversable g, HFunctor h, Monad m)
@@ -388,15 +411,6 @@
           run' :: NatM m (Term f :+: a)  (Term f)
           run' (Inl t) = return t
           run' (Inr a) = run a
-
-----------------------------------
--- CV-Algebras & Histomorphisms --
-----------------------------------
-
--- $l1 For this to work we need a more general version of @:&&:@ which is of
--- kind @((* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> *@,
--- i.e. one which takes a functor as second argument instead of a
--- type.
 
 -----------------------------------
 -- CV-Coalgebras & Futumorphisms --
diff --git a/src/Data/Comp/Multi/Annotation.hs b/src/Data/Comp/Multi/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Annotation.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses,
+  FlexibleInstances, UndecidableInstances, RankNTypes, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Annotation
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines annotations on signatures. All definitions are
+-- generalised versions of those in "Data.Comp.Annotation".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Annotation
+    (
+     (:&:) (..),
+     DistAnn (..),
+     RemA (..),
+     liftA,
+     ann,
+     liftA',
+     stripA,
+     propAnn,
+     project'
+    ) where
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Ops
+import qualified Data.Comp.Ops as O
+import Data.Comp.Multi.Algebra
+import Data.Comp.Multi.Functor
+
+import Control.Monad
+
+-- | This function transforms a function with a domain constructed
+-- from a functor to a function with a domain constructed with the
+-- same functor but with an additional annotation.
+liftA :: (RemA s s') => (s' a :-> t) -> s a :-> t
+liftA f v = f (remA v)
+
+
+-- | This function annotates each sub term of the given term with the
+-- given value (of type a).
+
+ann :: (DistAnn f p g, HFunctor f) => p -> CxtFun f g
+ann c = appSigFun (injectA c)
+
+-- | This function transforms a function with a domain constructed
+-- from a functor to a function with a domain constructed with the
+-- same functor but with an additional annotation.
+liftA' :: (DistAnn s' p s, HFunctor s')
+       => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a
+liftA' f v = let (v' O.:&: p) = projectA v
+             in ann p (f v')
+    
+{-| This function strips the annotations from a term over a
+functor with annotations. -}
+
+stripA :: (RemA g f, HFunctor g) => CxtFun g f
+stripA = appSigFun remA
+
+
+propAnn :: (DistAnn f p f', DistAnn g p g', HFunctor g) 
+               => TermHom f g -> TermHom f' g'
+propAnn alg f' = ann p (alg f)
+    where (f O.:&: p) = projectA f'
+
+-- | This function is similar to 'project' but applies to signatures
+-- with an annotation which is then ignored.
+
+-- project' :: (RemA s s',s :<: f) =>
+--      NatM Maybe (Cxt h f a) (s' (Cxt h f a))
+project' v = liftM remA $ project v
diff --git a/src/Data/Comp/Multi/Derive.hs b/src/Data/Comp/Multi/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive.hs
@@ -0,0 +1,48 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module contains functionality for automatically deriving boilerplate
+-- code using Template Haskell. Examples include instances of 'HFunctor',
+-- 'HFoldable', and 'HTraversable'.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive
+    (
+     derive,
+     -- |Derive boilerplate instances for higher-order signatures, i.e.
+     -- signatures for generalised compositional data types.
+
+     -- ** HShowF
+     module Data.Comp.Multi.Derive.Show,
+     -- ** HEqF
+     module Data.Comp.Multi.Derive.Equality,
+     -- ** HFunctor
+     module Data.Comp.Multi.Derive.Functor,
+     -- ** HFoldable
+     module Data.Comp.Multi.Derive.Foldable,
+     -- ** HTraversable
+     module Data.Comp.Multi.Derive.Traversable,
+     -- ** Smart Constructors
+     module Data.Comp.Multi.Derive.SmartConstructors,
+     -- ** Smart Constructors w/ Annotations
+     module Data.Comp.Multi.Derive.SmartAConstructors,
+     -- ** Lifting to Sums
+     module Data.Comp.Multi.Derive.LiftSum
+    ) where
+
+import Data.Comp.Derive.Utils (derive)
+import Data.Comp.Multi.Derive.Equality
+import Data.Comp.Multi.Derive.Show
+import Data.Comp.Multi.Derive.Functor
+import Data.Comp.Multi.Derive.Foldable
+import Data.Comp.Multi.Derive.Traversable
+import Data.Comp.Multi.Derive.SmartConstructors
+import Data.Comp.Multi.Derive.SmartAConstructors
+import Data.Comp.Multi.Derive.LiftSum
diff --git a/src/Data/Comp/Multi/Derive/Equality.hs b/src/Data/Comp/Multi/Derive/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Equality.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Equality
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HEqF@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Multi.Derive.Equality
+    (
+     HEqF(..),
+     KEq(..),
+     makeHEqF
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Functor
+import Language.Haskell.TH hiding (Cxt, match)
+
+
+class KEq f where
+    keq :: f i -> f j -> Bool
+
+{-| Signature equality. An instance @HEqF f@ gives rise to an instance
+  @KEq (HTerm f)@. -}
+class HEqF f where
+
+    heqF :: KEq g => f g i -> f g j -> Bool
+
+
+instance KEq f => Eq (f i) where
+    (==) = keq
+
+instance Eq a => KEq (K a) where
+    keq (K x) (K y) = x == y
+
+instance KEq a => Eq (A a) where
+     A x == A y = x `keq`  y
+
+{-| Derive an instance of 'HEqF' for a type constructor of any higher-order
+  kind taking at least two arguments. -}
+makeHEqF :: Name -> Q [Dec]
+makeHEqF fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+      argNames = (map (VarT . tyVarBndrName) (init args'))
+      ftyp = VarT . tyVarBndrName $ last args'
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (ClassP ''Eq . (: [])) argNames
+      classType = AppT (ConT ''HEqF) complType
+  constrs' <- mapM normalConExp constrs
+  eqFDecl <- funD 'heqF  (eqFClauses ftyp constrs constrs')
+  return [InstanceD preCond classType [eqFDecl]]
+      where eqFClauses ftyp constrs constrs' = map (genEqClause ftyp) constrs'
+                                   ++ defEqClause constrs
+            filterFarg fArg ty x = (containsType ty fArg, varE x)
+            defEqClause constrs
+                | length constrs  < 2 = []
+                | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]
+            genEqClause ftyp (constr, argts) = do 
+              let n = length argts
+              varNs <- newNames n "x"
+              varNs' <- newNames n "y"
+              let pat = ConP constr $ map VarP varNs
+                  pat' = ConP constr $ map VarP varNs'
+                  vars = map VarE varNs
+                  vars' = map VarE varNs'
+                  mkEq ty x y = let (x',y') = (return x,return y)
+                                in if containsType ty ftyp
+                                   then [| $x' `keq` $y'|]
+                                   else [| $x' == $y'|]
+                  eqs = listE $ zipWith3 mkEq argts vars vars'
+              body <- if n == 0 
+                      then [|True|]
+                      else [|and $eqs|]
+              return $ Clause [pat, pat'] (NormalB body) []
diff --git a/src/Data/Comp/Multi/Derive/Foldable.hs b/src/Data/Comp/Multi/Derive/Foldable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Foldable.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Foldable
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HFoldable@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.Foldable
+    (
+     HFoldable,
+     makeHFoldable
+    )where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+import Data.Foldable
+import Language.Haskell.TH
+import Data.Monoid
+import Data.Maybe
+import qualified Prelude as P (foldl,foldr,foldl1)
+import Prelude hiding  (foldl,foldr,foldl1)
+import Control.Monad
+
+
+iter 0 _ e = e
+iter n f e = iter (n-1) f (f `appE` e)
+
+iter' n f e = run n f e
+    where run 0 _ e = e
+          run m f e = let f' = iter (m-1) [|fmap|] f
+                      in run (m-1) f (f' `appE` e)
+
+iterSp n f g e = run n e
+    where run 0 e = e
+          run m e = let f' = iter (m-1) [|fmap|] (if n == m then g else f)
+                    in run (m-1) (f' `appE` e)
+
+{-| Derive an instance of 'HFoldable' for a type constructor of any higher-order
+  kind taking at least two arguments. -}
+makeHFoldable :: Name -> Q [Dec]
+makeHFoldable fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+      fArg = VarT . tyVarBndrName $ last args'
+      argNames = (map (VarT . tyVarBndrName) (init args'))
+      complType = P.foldl AppT (ConT name) argNames
+      classType = AppT (ConT ''HFoldable) complType
+  constrs' <- mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
+  foldDecl <- funD 'hfold (map foldClause constrs')
+  foldMapDecl <- funD 'hfoldMap (map foldMapClause constrs')
+  foldlDecl <- funD 'hfoldl (map foldlClause constrs')
+  foldrDecl <- funD 'hfoldr (map foldrClause constrs')
+  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl]]
+      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)
+            filterVar [] _ = Nothing
+            filterVar [d] x =Just (d, varE x)
+            filterVar _ _ =  error "functor variable occurring twice in argument type"
+            filterVars args varNs = catMaybes $ zipWith filterVar args varNs
+            mkCPat constr args varNs = ConP constr $ zipWith mkPat args varNs
+            mkPat [] _ = WildP
+            mkPat _ x = VarP x
+            mkPatAndVars (constr, args) =
+                do varNs <- newNames (length args) "x"
+                   return (mkCPat constr args varNs, filterVars args varNs)
+            foldClause (pat,vars) =
+                do let conApp (0,x) = [|unK $x|]
+                       conApp (d,x) = iterSp d [|fold|] [| foldMap unK |] x
+                   body <- if null vars
+                           then [|mempty|]
+                           else P.foldl1 (\ x y -> [|$x `mappend` $y|])
+                                    $ map conApp vars
+                   return $ Clause [pat] (NormalB body) []
+            foldMapClause (pat,vars) =
+                do fn <- newName "y"
+                   let f = varE fn
+                       f' 0 = f
+                       f' n = iter (n-1) [|fmap|] [| foldMap $f |]
+                       fp = if null vars then WildP else VarP fn
+                   body <- case vars of
+                             [] -> [|mempty|]
+                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $ 
+                                      map (\ (d,z) -> iter' (max (d-1) 0) [|fold|] (f' d `appE` z)) vars
+                   return $ Clause [fp, pat] (NormalB body) []
+            foldlClause (pat,vars) =
+                do fn <- newName "f"
+                   en <- newName "e"
+                   let f = varE fn
+                       e = varE en
+                       fp = if null vars then WildP else VarP fn
+                       ep = VarP en
+                       conApp x (0,y) = [|$f $x $y|]
+                       conApp x (1,y) = [|foldl $f $x $y|]
+                       conApp x (d,y) = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldl $f)|] `appE` y
+                                            endo = iter' (d-1) [|fold|] hidEndo
+                                        in [| appEndo $endo $x|]
+                   body <- P.foldl conApp e vars
+                   return $ Clause [fp, ep, pat] (NormalB body) []
+            foldrClause (pat,vars) =
+                do fn <- newName "f"
+                   en <- newName "e"
+                   let f = varE fn
+                       e = varE en
+                       fp = if null vars then WildP else VarP fn
+                       ep = VarP en
+                       conApp (0,x) y = [|$f $x $y|]
+                       conApp (1,x) y = [|foldr $f $y $x |]
+                       conApp (d,x) y = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldr $f)|] `appE` x
+                                            endo = iter' (d-1) [|fold|] hidEndo
+                                        in [| appEndo $endo $y|]
+                   body <- P.foldr conApp e vars
+                   return $ Clause [fp, ep, pat] (NormalB body) []
diff --git a/src/Data/Comp/Multi/Derive/Functor.hs b/src/Data/Comp/Multi/Derive/Functor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Functor.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Functor
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HFunctor@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.Functor
+    (
+     HFunctor,
+     makeHFunctor
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Functor
+import Language.Haskell.TH
+import qualified Prelude as P (mapM)
+import Prelude hiding (mapM)
+import Data.Maybe
+import Control.Monad
+
+iter 0 _ e = e
+iter n f e = iter (n-1) f (f `appE` e)
+
+{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order
+  kind taking at least two arguments. -}
+makeHFunctor :: Name -> Q [Dec]
+makeHFunctor fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+      fArg = VarT . tyVarBndrName $ last args'
+      argNames = (map (VarT . tyVarBndrName) (init args'))
+      complType = foldl AppT (ConT name) argNames
+      classType = AppT (ConT ''HFunctor) complType
+  constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
+  hfmapDecl <- funD 'hfmap (map hfmapClause constrs')
+  return [InstanceD [] classType [hfmapDecl]]
+      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)
+            filterVar _ nonFarg [] x  = nonFarg x
+            filterVar farg _ [depth] x = farg depth x
+            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"
+            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs
+            mkCPat constr varNs = ConP constr $ map mkPat varNs
+            mkPat = VarP
+            mkPatAndVars (constr, args) =
+                do varNs <- newNames (length args) "x"
+                   return (conE constr, mkCPat constr varNs,
+                           \ f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),
+                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))
+            hfmapClause (con, pat,vars',hasFargs,_,_) =
+                do fn <- newName "f"
+                   let f = varE fn
+                       fp = if hasFargs then VarP fn else WildP
+                       vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id
+                   body <- foldl appE con vars
+                   return $ Clause [fp, pat] (NormalB body) []
diff --git a/src/Data/Comp/Multi/Derive/Injections.hs b/src/Data/Comp/Multi/Derive/Injections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Injections.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Injections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature injections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.Injections
+    (
+     injn,
+     injectn,
+     deepInjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Algebra (CxtFun, appSigFun)
+import Data.Comp.Multi.Ops ((:+:)(..), (:<:)(..))
+
+injn :: Int -> Q [Dec]
+injn n = do
+  let i = mkName $ "inj" ++ show n
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let ivar = mkName "i"
+  let xvar = mkName "x"
+  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar ivar) : d
+    where genSig fvars gvar avar ivar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT ivar)
+                             `appT` (varT gvar `appT` varT avar
+                                               `appT` varT ivar)
+            forallT (map PlainTV $ gvar : avar : ivar : fvars)
+                    (sequence cxt) tp'
+          genDecl x n = [| case $(varE x) of
+                             Inl x -> $(varE $ mkName $ "inj") x
+                             Inr x -> $(varE $ mkName $ "inj" ++
+                                        if n > 2 then show (n - 1) else "") x |]
+injectn :: Int -> Q [Dec]
+injectn n = do
+  let i = mkName ("inject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let ivar = mkName "i"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar ivar) : d
+    where genSig fvars gvar avar ivar = do
+            let hvar = mkName "h"
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar
+                                 `appT` varT avar
+            let tp'' = arrowT `appT` (tp `appT` tp' `appT` varT ivar)
+                              `appT` (tp' `appT` varT ivar)
+            forallT (map PlainTV $ hvar : gvar : avar : ivar : fvars)
+                    (sequence cxt) tp''
+          genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]
+
+deepInjectn :: Int -> Q [Dec]
+deepInjectn n = do
+  let i = mkName ("deepInject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar) : d
+    where genSig fvars gvar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let cxt' = classP ''HFunctor [tp]
+            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar
+            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
diff --git a/src/Data/Comp/Multi/Derive/LiftSum.hs b/src/Data/Comp/Multi/Derive/LiftSum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/LiftSum.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.LiftSum
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Lift a class declaration for higher-order functors to sums of higher-order
+-- functors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.LiftSum
+    (
+     liftSum,
+     caseH
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Ops ((:+:)(..))
+
+{-| Given the name of a type class, where the first parameter is a higher-order
+  functor, lift it to sums of higher-order. Example: @class HShowF f where ...@
+  is lifted as @instance (HShowF f, HShowF g) => HShowF (f :+: g) where ... @.
+ -}
+liftSum :: Name -> Q [Dec]
+liftSum fname = do
+  ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname
+  let targs' = map tyVarBndrName $ tail targs
+  let f = mkName "f"
+  let g = mkName "g"
+  let cxt = [ClassP name (map VarT $ f : targs'),
+             ClassP name (map VarT $ g : targs')]
+  let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)
+  let complType = foldl (\a x -> a `AppT` VarT x) tp targs'
+  decs' <- sequence $ concatMap decl decs
+  return [InstanceD cxt complType decs']
+      where decl :: Dec -> [DecQ]
+            decl (SigD f _) = [funD f [clause f]]
+            decl _ = []
+            clause :: Name -> ClauseQ
+            clause f = do x <- newName "x"
+                          b <- normalB [|caseH $(varE f) $(varE f) $(varE x)|]
+                          return $ Clause [VarP x] b []
+
+{-| Utility function to case on a higher-order functor sum, without exposing the
+  internal representation of sums. -}
+caseH :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c
+caseH f g x = case x of
+                Inl x -> f x
+                Inr x -> g x
diff --git a/src/Data/Comp/Multi/Derive/Projections.hs b/src/Data/Comp/Multi/Derive/Projections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Projections.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE TemplateHaskell, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Projections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature projections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.Projections
+    (
+     projn,
+     projectn,
+     deepProjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Control.Monad (liftM)
+import Data.Comp.Multi.Traversable (HTraversable)
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Algebra (CxtFunM, appSigFunM')
+import Data.Comp.Multi.Ops ((:+:)(..), (:<:)(..))
+
+projn :: Int -> Q [Dec]
+projn n = do
+  let p = mkName $ "proj" ++ show n
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let ivar = mkName "i"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar ivar) []]]
+  sequence $ (sigD p $ genSig gvars avar ivar) : d
+    where genSig gvars avar ivar = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = arrowT
+                      `appT` (varT fvar `appT` varT avar `appT` varT ivar)
+                      `appT` (conT ''Maybe `appT`
+                              (tp `appT` varT avar `appT` varT ivar))
+            forallT (map PlainTV $ fvar : ivar : avar : gvars)
+                    (sequence cxt) tp'
+          genDecl x [g] a i =
+            [| liftM inj (proj $(varE x)
+                          :: Maybe ($(varT g `appT` varT a `appT` varT i))) |]
+          genDecl x (g:gs) a i =
+            [| case (proj $(varE x)
+                         :: Maybe ($(varT g `appT` varT a `appT` varT i))) of
+                 Just y -> Just $ inj y
+                 _ -> $(genDecl x gs a i) |]
+          genDecl _ _ _ _ = error "genDecl called with empty list"
+
+projectn :: Int -> Q [Dec]
+projectn n = do
+  let p = mkName ("project" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let ivar = mkName "i"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD p $ genSig gvars avar ivar) : d
+    where genSig gvars avar ivar = do
+            let fvar = mkName "f"
+            let hvar = mkName "h"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar
+                                 `appT` varT avar
+            let tp'' = arrowT `appT` (tp' `appT` varT ivar)
+                              `appT` (conT ''Maybe `appT`
+                                      (tp `appT` tp' `appT` varT ivar))
+            forallT (map PlainTV $ hvar : fvar : avar : ivar : gvars)
+                    (sequence cxt) tp''
+          genDecl x n = [| case $(varE x) of
+                             Hole _ -> Nothing
+                             Term t -> $(varE $ mkName $ "proj" ++ show n) t |]
+
+deepProjectn :: Int -> Q [Dec]
+deepProjectn n = do
+  let p = mkName ("deepProject" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let d = [funD p [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD p $ genSig gvars) : d
+    where genSig gvars = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let cxt' = classP ''HTraversable [tp]
+            let tp' = conT ''CxtFunM `appT` conT ''Maybe
+                                     `appT` varT fvar `appT` tp
+            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
diff --git a/src/Data/Comp/Multi/Derive/Show.hs b/src/Data/Comp/Multi/Derive/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Show.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Show
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HShowF@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.Show
+    (
+     HShowF(..),
+     KShow(..),
+     makeHShowF
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Algebra
+import Language.Haskell.TH
+
+{-| Signature printing. An instance @HShowF f@ gives rise to an instance
+  @KShow (HTerm f)@. -}
+class HShowF f where
+    hshowF :: Alg f (K String)
+    hshowF = K . hshowF'
+    hshowF' :: f (K String) :=> String
+    hshowF' = unK . hshowF
+
+class KShow a where
+    kshow :: a i -> K String i
+
+showConstr :: String -> [String] -> String
+showConstr con [] = con
+showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"
+
+{-| Derive an instance of 'HShowF' for a type constructor of any higher-order
+  kind taking at least two arguments. -}
+makeHShowF :: Name -> Q [Dec]
+makeHShowF fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+      fArg = VarT . tyVarBndrName $ last args'
+      argNames = (map (VarT . tyVarBndrName) (init args'))
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (ClassP ''Show . (: [])) argNames
+      classType = AppT (ConT ''HShowF) complType
+  constrs' <- mapM normalConExp constrs
+  showFDecl <- funD 'hshowF (showFClauses fArg constrs')
+  return [InstanceD preCond classType [showFDecl]]
+      where showFClauses fArg = map (genShowFClause fArg)
+            filterFarg fArg ty x = (containsType ty fArg, varE x)
+            mkShow (isFArg, var)
+                | isFArg = [|unK $var|]
+                | otherwise = [| show $var |]
+            genShowFClause fArg (constr, args) = do 
+              let n = length args
+              varNs <- newNames n "x"
+              let pat = ConP constr $ map VarP varNs
+                  allVars = zipWith (filterFarg fArg) args varNs
+                  shows = listE $ map mkShow allVars
+                  conName = nameBase constr
+              body <- [|K $ showConstr conName $shows|]
+              return $ Clause [pat] (NormalB body) []
diff --git a/src/Data/Comp/Multi/Derive/SmartAConstructors.hs b/src/Data/Comp/Multi/Derive/SmartAConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/SmartAConstructors.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.SmartAConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors with annotations.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.SmartAConstructors 
+    (
+     smartAConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Annotation
+import Control.Monad
+
+{-| Derive smart constructors with products for a type constructor of any
+  parametric kind taking at least two arguments. The smart constructors are
+  similar to the ordinary constructors, but an 'injectA' is automatically
+  inserted. -}
+smartAConstructors :: Name -> Q [Dec]
+smartAConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let cons = map abstractConType constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where genSmartConstr targs tname (name, args) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args
+              genSmartConstr' targs tname sname name args = do
+                varNs <- newNames args "x"
+                varPr <- newName "_p"
+                let pats = map varP (varPr : varNs)
+                    vars = map varE varNs
+                    val = appE [|injectA $(varE varPr)|] $
+                          appE [|inj|] $ foldl appE (conE name) vars
+                    function = [funD sname [clause pats (normalB [|Term $val|]) []]]
+                sequence function
diff --git a/src/Data/Comp/Multi/Derive/SmartConstructors.hs b/src/Data/Comp/Multi/Derive/SmartConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/SmartConstructors.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.SmartConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors for mutually recursive types.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.SmartConstructors 
+    (
+     smartConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Term
+
+import Control.Monad
+
+{-| Derive smart constructors for a type constructor of any higher-order kind
+ taking at least two arguments. The smart constructors are similar to the
+ ordinary constructors, but an 'inject' is automatically inserted. -}
+smartConstructors :: Name -> Q [Dec]
+smartConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let iVar = tyVarBndrName $ last targs
+    let cons = map (\con -> (abstractConType con, iTp iVar con)) constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where iTp iVar (ForallC _ cxt _) =
+                  -- Check if the GADT phantom type is constrained
+                  case [y | EqualP x y <- cxt, x == VarT iVar] of
+                    [] -> Nothing
+                    tp:_ -> Just tp
+              iTp _ _ = Nothing
+              genSmartConstr targs tname ((name, args), miTp) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ 'i' : bname) name args miTp
+              genSmartConstr' targs tname sname name args miTp = do
+                varNs <- newNames args "x"
+                let pats = map varP varNs
+                    vars = map varE varNs
+                    val = foldl appE (conE name) vars
+                    sig = genSig targs tname sname args miTp
+                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]
+                sequence $ sig ++ function
+              genSig targs tname sname 0 miTp = (:[]) $ do
+                fvar <- newName "f"
+                hvar <- newName "h"
+                avar <- newName "a"
+                ivar <- newName "i"
+                let targs' = init $ init targs
+                    vars = hvar:fvar:avar:(maybe [ivar] (const []) miTp)++targs'
+                    f = varT fvar
+                    h = varT hvar
+                    a = varT avar
+                    i = varT ivar
+                    ftype = foldl appT (conT tname) (map varT targs')
+                    constr = classP ''(:<:) [ftype, f]
+                    typ = foldl appT (conT ''Cxt) [h, f, a, maybe i return miTp]
+                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ
+                sigD sname typeSig
+              genSig _ _ _ _ _ = []
diff --git a/src/Data/Comp/Multi/Derive/Traversable.hs b/src/Data/Comp/Multi/Derive/Traversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Derive/Traversable.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Derive.Traversable
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HTraversable@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Derive.Traversable
+    (
+     HTraversable,
+     makeHTraversable
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Multi.Traversable
+import Language.Haskell.TH
+import Data.Maybe
+import Data.Traversable
+import Data.Foldable hiding (any,or)
+import Control.Applicative
+import Control.Monad hiding (mapM, sequence)
+import qualified Prelude as P (foldl, foldr, mapM)
+import Prelude hiding  (foldl, foldr,mapM, sequence)
+
+iter 0 _ e = e
+iter n f e = iter (n-1) f (f `appE` e)
+
+iter' n f e = run n f e
+    where run 0 _ e = e
+          run m f e = let f' = iter (m-1) [|fmap|] f
+                        in run (m-1) f (f' `appE` e)
+
+{-| Derive an instance of 'HTraversable' for a type constructor of any
+  higher-order kind taking at least two arguments. -}
+makeHTraversable :: Name -> Q [Dec]
+makeHTraversable fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+      fArg = VarT . tyVarBndrName $ last args'
+      argNames = (map (VarT . tyVarBndrName) (init args'))
+      complType = foldl AppT (ConT name) argNames
+      classType = AppT (ConT ''HTraversable) complType
+  constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
+  traverseDecl <- funD 'htraverse (map traverseClause constrs')
+  mapMDecl <- funD 'hmapM (map mapMClause constrs')
+  return [InstanceD [] classType [traverseDecl, mapMDecl]]
+      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)
+            filterVar _ nonFarg [] x  = nonFarg x
+            filterVar farg _ [depth] x = farg depth x
+            filterVar _ _ _ _ = error "functor variable occurring twice in argument type"
+            filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs
+            mkCPat constr varNs = ConP constr $ map mkPat varNs
+            mkPat = VarP
+            mkPatAndVars (constr, args) =
+                do varNs <- newNames (length args) "x"
+                   return (conE constr, mkCPat constr varNs,
+                           \f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),
+                           any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))
+            traverseClause (con, pat,vars',hasFargs,_,_) =
+                do fn <- newName "f"
+                   let f = varE fn
+                       fp = if hasFargs then VarP fn else WildP
+                       vars = vars' (\d x -> iter d [|traverse|] f `appE` x) (\x -> [|pure $x|])
+                   body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars
+                   return $ Clause [fp, pat] (NormalB body) []
+            -- Note: the monadic versions are not defined
+            -- applicatively, as this results in a considerable
+            -- performance penalty (by factor 2)!
+            mapMClause (con, pat,_,hasFargs,allVars, fvars) =
+                do fn <- newName "f"
+                   let f = varE fn
+                       fp = if hasFargs then VarP fn else WildP
+                       conAp = P.foldl appE con allVars
+                       conBind (d,x) y = [| $(iter d [|mapM|] f) $(varE x)  >>= $(lamE [varP x] y)|]
+                   body <- P.foldr conBind [|return $conAp|] fvars
+                   return $ Clause [fp, pat] (NormalB body) []
diff --git a/src/Data/Comp/Multi/Desugar.hs b/src/Data/Comp/Multi/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Desugar.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, TypeOperators, OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Desugar
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This modules defines the 'Desugar' type class for desugaring of terms.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Desugar where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Derive
+
+-- |The desugaring term homomorphism.
+class (HFunctor f, HFunctor g) => Desugar f g where
+    desugHom :: TermHom f g
+    desugHom = desugHom' . hfmap Hole
+    desugHom' :: Alg f (Context g a)
+    desugHom' x = appCxt (desugHom x)
+
+$(derive [liftSum] [''Desugar])
+
+-- |Desugar a term.
+desugar :: Desugar f g => Term f :-> Term g
+desugar = appTermHom desugHom
+
+-- |Lift desugaring to annotated terms.
+desugarA :: (HFunctor f', HFunctor g', DistAnn f p f', DistAnn g p g',
+             Desugar f g) => Term f' :-> Term g'
+desugarA = appTermHom (propAnn desugHom)
+
+-- |Default desugaring instance.
+instance (HFunctor f, HFunctor g, f :<: g) => Desugar f g where
+    desugHom = simpCxt . inj
diff --git a/src/Data/Comp/Multi/Equality.hs b/src/Data/Comp/Multi/Equality.hs
--- a/src/Data/Comp/Multi/Equality.hs
+++ b/src/Data/Comp/Multi/Equality.hs
@@ -22,7 +22,8 @@
 
 import Data.Comp.Multi.Term
 import Data.Comp.Multi.Sum
-import Data.Comp.Derive
+import Data.Comp.Multi.Ops
+import Data.Comp.Multi.Derive
 
 import Data.Comp.Multi.Functor
 import Data.Comp.Multi.Foldable
diff --git a/src/Data/Comp/Multi/Generic.hs b/src/Data/Comp/Multi/Generic.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Generic.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE GADTs, ExistentialQuantification, TypeOperators, ScopedTypeVariables, RankNTypes #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Generic
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines type generic functions and recursive schemes
+-- along the lines of the Uniplate library. All definitions are
+-- generalised versions of those in "Data.Comp.Generic".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Generic where
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+import Data.Comp.Multi.Traversable
+import GHC.Exts
+import Control.Monad
+import Prelude
+
+import Data.Maybe
+
+-- | This function returns a list of all subterms of the given
+-- term. This function is similar to Uniplate's @universe@ function.
+subterms :: forall f  . HFoldable f => Term f  :=> [A (Term f)]
+subterms t = build (f t)
+    where f :: Term f :=> (A (Term f) -> b -> b) -> b -> b
+          f t cons nil = A t `cons` hfoldl (\u s -> f s cons u) nil (unTerm t)
+
+-- | This function returns a list of all subterms of the given term
+-- that are constructed from a particular functor.
+subterms' :: forall f g . (HFoldable f, g :<: f) => Term f :=> [A (g (Term f))]
+subterms' (Term t) = build (f t)
+    where f :: f (Term f) :=> (A (g (Term f)) -> b -> b) -> b -> b
+          f t cons nil = let rest = hfoldl (\u (Term s) -> f s cons u) nil t
+                         in case proj t of
+                              Just t' -> A t' `cons` rest
+                              Nothing -> rest
+
+-- | This function transforms every subterm according to the given
+-- function in a bottom-up manner. This function is similar to
+-- Uniplate's @transform@ function.
+transform :: forall f . (HFunctor f) => (Term f :-> Term f) -> Term f :-> Term f
+transform f = run
+    where run :: Term f :-> Term f
+          run = f . Term . hfmap run . unTerm
+
+
+-- | Monadic version of 'transform'.
+transformM :: forall f m . (HTraversable f, Monad m) =>
+             NatM m (Term f) (Term f) -> NatM m (Term f) (Term f)
+transformM  f = run 
+    where run :: NatM m (Term f) (Term f)
+          run t = f =<< liftM Term (hmapM run $ unTerm t)
+
+query :: HFoldable f => (Term f :=>  r) -> (r -> r -> r) -> Term f :=> r
+-- query q c = run 
+--     where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t
+query q c i@(Term t) = hfoldl (\s x -> s `c` query q c x) (q i) t
+
+subs :: HFoldable f => Term f  :=> [A (Term f)]
+subs = query (\x-> [A x]) (++)
+
+subs' :: (HFoldable f, g :<: f) => Term f :=> [A (g (Term f))]
+subs' = mapMaybe pr . subs
+        where pr (A v) = fmap A (project v)
+
+-- | This function computes the generic size of the given term,
+-- i.e. the its number of subterm occurrences.
+size :: HFoldable f => Cxt h f a :=> Int
+size (Hole {}) = 0
+size (Term t) = hfoldl (\s x -> s + size x) 1 t
+
+-- | This function computes the generic depth of the given term.
+depth :: HFoldable f => Cxt h f a :=> Int
+depth (Hole {}) = 0
+depth (Term t) = 1 + hfoldl (\s x -> s + size x) 0 t
diff --git a/src/Data/Comp/Multi/Ops.hs b/src/Data/Comp/Multi/Ops.hs
--- a/src/Data/Comp/Multi/Ops.hs
+++ b/src/Data/Comp/Multi/Ops.hs
@@ -120,40 +120,38 @@
     htraverse f (v :&: c) =  (:&: c) <$> (htraverse f v)
     hmapM f (v :&: c) = liftM (:&: c) (hmapM f v)
 
--- | This class defines how to distribute a product over a sum of
+-- | This class defines how to distribute an annotation over a sum of
 -- signatures.
-
-class DistProd (s :: (* -> *) -> * -> *) p s' | s' -> s, s' -> p where
-        
-    -- | This function injects a product a value over a signature.
-    injectP :: p -> s a :-> s' a
-    projectP :: s' a :-> (s a O.:&: p)
+class DistAnn (s :: (* -> *) -> * -> *) p s' | s' -> s, s' -> p where
+    -- | This function injects an annotation over a signature.
+    injectA :: p -> s a :-> s' a
+    projectA :: s' a :-> (s a O.:&: p)
 
 
-class RemoveP (s :: (* -> *) -> * -> *) s' | s -> s'  where
-    removeP :: s a :-> s' a
+class RemA (s :: (* -> *) -> * -> *) s' | s -> s'  where
+    remA :: s a :-> s' a
 
 
-instance (RemoveP s s') => RemoveP (f :&: p :+: s) (f :+: s') where
-    removeP (Inl (v :&: _)) = Inl v
-    removeP (Inr v) = Inr $ removeP v
+instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where
+    remA (Inl (v :&: _)) = Inl v
+    remA (Inr v) = Inr $ remA v
 
 
-instance RemoveP (f :&: p) f where
-    removeP (v :&: _) = v
+instance RemA (f :&: p) f where
+    remA (v :&: _) = v
 
 
-instance DistProd f p (f :&: p) where
+instance DistAnn f p (f :&: p) where
 
-    injectP p v = v :&: p
+    injectA p v = v :&: p
 
-    projectP (v :&: p) = v O.:&: p
+    projectA (v :&: p) = v O.:&: p
 
 
-instance (DistProd s p s') => DistProd (f :+: s) p ((f :&: p) :+: s') where
-    injectP p (Inl v) = Inl (v :&: p)
-    injectP p (Inr v) = Inr $ injectP p v
+instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where
+    injectA p (Inl v) = Inl (v :&: p)
+    injectA p (Inr v) = Inr $ injectA p v
 
-    projectP (Inl (v :&: p)) = (Inl v O.:&: p)
-    projectP (Inr v) = let (v' O.:&: p) = projectP v
+    projectA (Inl (v :&: p)) = (Inl v O.:&: p)
+    projectA (Inr v) = let (v' O.:&: p) = projectA v
                         in  (Inr v' O.:&: p)
diff --git a/src/Data/Comp/Multi/Product.hs b/src/Data/Comp/Multi/Product.hs
deleted file mode 100644
--- a/src/Data/Comp/Multi/Product.hs
+++ /dev/null
@@ -1,87 +0,0 @@
-{-# LANGUAGE TypeOperators, MultiParamTypeClasses,
-  FlexibleInstances, UndecidableInstances, RankNTypes, GADTs #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Multi.Product
--- Copyright   :  (c) 2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- This module defines products on signatures. All definitions are
--- generalised versions of those in "Data.Comp.Product".
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Multi.Product
-    ( (:&:) (..),
-      DistProd (..),
-      RemoveP (..),
-      liftP,
-      constP,
-      liftP',
-      stripP,
-      productTermHom,
-      project'
-    )where
-
-import Data.Comp.Multi.Term
-import Data.Comp.Multi.Sum
-import Data.Comp.Multi.Ops
-import qualified Data.Comp.Ops as O
-import Data.Comp.Multi.Algebra
-import Data.Comp.Multi.Functor
-
-import Control.Monad
-
-
-
-
--- | This function transforms a function with a domain constructed
--- from a functor to a function with a domain constructed with the
--- same functor but with an additional product.
-
-liftP :: (RemoveP s s') => (s' a :-> t) -> s a :-> t
-liftP f v = f (removeP v)
-
-
--- | This function annotates each sub term of the given term with the
--- given value (of type a).
-
-constP :: (DistProd f p g, HFunctor f, HFunctor g) 
-       => p -> Cxt h f a :-> Cxt h g a
-constP c = appSigFun (injectP c)
-
--- | This function transforms a function with a domain constructed
--- from a functor to a function with a domain constructed with the
--- same functor but with an additional product.
-
-liftP' :: (DistProd s' p s, HFunctor s, HFunctor s')
-       => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a
-liftP' f v = let (v' O.:&: p) = projectP v
-             in constP p (f v')
-    
-{-| This function strips the products from a term over a
-functor whith products. -}
-
-stripP :: (HFunctor f, RemoveP g f, HFunctor g)
-       => Cxt h g a :-> Cxt h f a
-stripP = appSigFun removeP
-
-
-productTermHom :: (DistProd f p f', DistProd g p g', HFunctor g, HFunctor g') 
-               => TermHom f g -> TermHom f' g'
-productTermHom alg f' = constP p (alg f)
-    where (f O.:&: p) = projectP f'
-
-
-
-
-
--- | This function is similar to 'project' but applies to signatures
--- with a product which is then ignored.
-
--- project' :: (RemoveP s s',s :<: f) =>
---      NatM Maybe (Cxt h f a) (s' (Cxt h f a))
-project' v = liftM removeP $ project v
diff --git a/src/Data/Comp/Multi/Show.hs b/src/Data/Comp/Multi/Show.hs
--- a/src/Data/Comp/Multi/Show.hs
+++ b/src/Data/Comp/Multi/Show.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeOperators, GADTs, FlexibleContexts,
-  ScopedTypeVariables, UndecidableInstances, FlexibleInstances #-}
+  ScopedTypeVariables, UndecidableInstances, FlexibleInstances,
+  TemplateHaskell #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Multi.Show
@@ -20,11 +21,10 @@
     ) where
 
 import Data.Comp.Multi.Term
-import Data.Comp.Multi.Sum
-import Data.Comp.Multi.Product
+import Data.Comp.Multi.Annotation
 import Data.Comp.Multi.Algebra
 import Data.Comp.Multi.Functor
-import Data.Comp.Derive
+import Data.Comp.Multi.Derive
 
 instance KShow Nothing where
     kshow _ = undefined
@@ -44,6 +44,4 @@
 instance (HShowF f, Show p) => HShowF (f :&: p) where
     hshowF (v :&: p) =  K $ unK (hshowF v) ++ " :&: " ++ show p
 
-instance (HShowF f, HShowF g) => HShowF (f :+: g) where
-    hshowF (Inl f) = hshowF f
-    hshowF (Inr g) = hshowF g
+$(derive [liftSum] [''HShowF])
diff --git a/src/Data/Comp/Multi/Sum.hs b/src/Data/Comp/Multi/Sum.hs
--- a/src/Data/Comp/Multi/Sum.hs
+++ b/src/Data/Comp/Multi/Sum.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, IncoherentInstances,
-  RankNTypes #-}
+  RankNTypes, FlexibleContexts, TemplateHaskell #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Multi.Sum
@@ -16,31 +16,72 @@
 
 module Data.Comp.Multi.Sum
     (
-     (:<:)(..),
-     (:+:)(..),
+     (:<:),
+     (:+:),
 
      -- * Projections for Signatures and Terms
+     proj,
      proj2,
      proj3,
+     proj4,
+     proj5,
+     proj6,
+     proj7,
+     proj8,
+     proj9,
+     proj10,
      project,
      project2,
      project3,
+     project4,
+     project5,
+     project6,
+     project7,
+     project8,
+     project9,
+     project10,
      deepProject,
      deepProject2,
      deepProject3,
---     deepProject',
---     deepProject2',
---     deepProject3',
+     deepProject4,
+     deepProject5,
+     deepProject6,
+     deepProject7,
+     deepProject8,
+     deepProject9,
+     deepProject10,
 
      -- * Injections for Signatures and Terms
+     inj,
      inj2,
      inj3,
+     inj4,
+     inj5,
+     inj6,
+     inj7,
+     inj8,
+     inj9,
+     inj10,
      inject,
      inject2,
      inject3,
+     inject4,
+     inject5,
+     inject6,
+     inject7,
+     inject8,
+     inject9,
+     inject10,
      deepInject,
      deepInject2,
      deepInject3,
+     deepInject4,
+     deepInject5,
+     deepInject6,
+     deepInject7,
+     deepInject8,
+     deepInject9,
+     deepInject10,
 
      -- * Injections and Projections for Constants
      injectConst,
@@ -58,95 +99,64 @@
 import Data.Comp.Multi.Ops
 import Data.Comp.Multi.Term
 import Data.Comp.Multi.Algebra
+import Data.Comp.Multi.Derive.Projections
+import Data.Comp.Multi.Derive.Injections
 import Control.Monad (liftM)
 
-{-| A variant of 'proj' for binary sum signatures.  -}
-proj2 :: forall f g1 g2 a i. (g1 :<: f, g2 :<: f) =>
-          f a i -> Maybe (((g1 :+: g2) a) i)
-proj2 x = case proj x of
-             Just (y :: g1 a i) -> Just $ inj y
-             _ -> liftM inj (proj x :: Maybe (g2 a i))
-
-{-| A variant of 'proj' for ternary sum signatures.  -}
-proj3 :: forall f g1 g2 g3 a i. (g1 :<: f, g2 :<: f, g3 :<: f) =>
-          f a i -> Maybe (((g1 :+: g2 :+: g3) a) i)
-proj3 x = case proj x of
-             Just (y :: g1 a i) -> Just $ inj y
-             _ -> case proj x of
-                    Just (y :: g2 a i) -> Just $ inj y
-                    _ -> liftM inj (proj x :: Maybe (g3 a i))
+$(liftM concat $ mapM projn [2..10])
 
--- |Project the outermost layer of a term to a sub signature.
-project :: (g :<: f) => NatM Maybe (Cxt h f a)  (g (Cxt h f a))
+-- |Project the outermost layer of a term to a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.
+project :: (g :<: f) => NatM Maybe (Cxt h f a) (g (Cxt h f a))
 project (Hole _) = Nothing
 project (Term t) = proj t
 
--- |Project the outermost layer of a term to a binary sub signature.
-project2 :: (g1 :<: f, g2 :<: f) =>
-             NatM Maybe (Cxt h f a) ((g1 :+: g2) (Cxt h f a))
-project2 (Hole _) = Nothing
-project2 (Term t) = proj2 t
-
--- |Project the outermost layer of a term to a ternary sub signature.
-project3 :: (g1 :<: f, g2 :<: f, g3 :<: f) =>
-             NatM Maybe (Cxt h f a) ((g1 :+: g2 :+: g3) (Cxt h f a))
-project3 (Hole _) = Nothing
-project3 (Term t) = proj3 t
-
--- |Project a term to a term over a sub signature.
-deepProject :: (HTraversable f, HFunctor g, g :<: f)
-             => NatM Maybe (Cxt h f a) (Cxt h g a)
-deepProject = appSigFunM proj
-
--- |Project a term to a term over a binary sub signature.
-deepProject2 :: (HTraversable f, HFunctor g1, HFunctor g2,
-                  g1 :<: f, g2 :<: f)
-              => NatM Maybe (Cxt h f a) (Cxt h (g1 :+: g2) a)
-deepProject2 = appSigFunM proj2
+$(liftM concat $ mapM projectn [2..10])
 
--- |Project a term to a term over a ternary sub signature.
-deepProject3 :: (HTraversable f, HFunctor g1, HFunctor g2, HFunctor g3,
-                  g1 :<: f, g2 :<: f, g3 :<: f)
-              => NatM Maybe (Cxt h f a) (Cxt h (g1 :+: g2 :+: g3) a)
-deepProject3 = appSigFunM proj3
+-- | Tries to coerce a term/context to a term/context over a sub-signature. If
+-- the signature @g@ is compound of /n/ atomic signatures, use
+-- @deepProject@/n/ instead.
+deepProject :: (HTraversable g, g :<: f)  => CxtFunM Maybe f g
+{-# INLINE deepProject #-}
+deepProject = appSigFunM' proj
 
-{-| A variant of 'inj' for binary sum signatures.  -}
-inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a :-> g a
-inj2 (Inl x) = inj x
-inj2 (Inr y) = inj y
+$(liftM concat $ mapM deepProjectn [2..10])
+{-# INLINE deepProject2 #-}
+{-# INLINE deepProject3 #-}
+{-# INLINE deepProject4 #-}
+{-# INLINE deepProject5 #-}
+{-# INLINE deepProject6 #-}
+{-# INLINE deepProject7 #-}
+{-# INLINE deepProject8 #-}
+{-# INLINE deepProject9 #-}
+{-# INLINE deepProject10 #-}
 
-{-| A variant of 'inj' for ternary sum signatures.  -}
-inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a :-> g a
-inj3 (Inl x) = inj x
-inj3 (Inr y) = inj2 y
+$(liftM concat $ mapM injn [2..10])
 
--- |Inject a term where the outermost layer is a sub signature.
+-- |Inject a term where the outermost layer is a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.
 inject :: (g :<: f) => g (Cxt h f a) :-> Cxt h f a
 inject = Term . inj
 
--- |Inject a term where the outermost layer is a binary sub signature.
-inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) (Cxt h g a) :-> Cxt h g a
-inject2 = Term . inj2
-
--- |Inject a term where the outermost layer is a ternary sub signature.
-inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g)
-         => (f1 :+: f2 :+: f3) (Cxt h g a) :-> Cxt h g a
-inject3 = Term . inj3
+$(liftM concat $ mapM injectn [2..10])
 
--- |Inject a term over a sub signature to a term over larger signature.
-deepInject :: (HFunctor g, HFunctor f, g :<: f) => Cxt h g a :-> Cxt h f a
+-- |Inject a term over a sub signature to a term over larger signature. If the
+-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/
+-- instead.
+deepInject :: (HFunctor g, g :<: f) => CxtFun g f
+{-# INLINE deepInject #-}
 deepInject = appSigFun inj
 
--- |Inject a term over a binary sub signature to a term over larger signature.
-deepInject2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<: g, f2 :<: g)
-             => Cxt h (f1 :+: f2) a :-> Cxt h g a
-deepInject2 = appSigFun inj2
-
--- |Inject a term over a ternary sub signature to a term over larger signature.
-deepInject3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,
-                 f1 :<: g, f2 :<: g, f3 :<: g)
-             => Cxt h (f1 :+: f2 :+: f3) a :-> Cxt h g a
-deepInject3 = appSigFun inj3
+$(liftM concat $ mapM deepInjectn [2..10])
+{-# INLINE deepInject2 #-}
+{-# INLINE deepInject3 #-}
+{-# INLINE deepInject4 #-}
+{-# INLINE deepInject5 #-}
+{-# INLINE deepInject6 #-}
+{-# INLINE deepInject7 #-}
+{-# INLINE deepInject8 #-}
+{-# INLINE deepInject9 #-}
+{-# INLINE deepInject10 #-}
 
 -- | This function injects a whole context into another context.
 injectCxt :: (HFunctor g, g :<: f) => Cxt h' g (Cxt h f a) :-> Cxt h f a
diff --git a/src/Data/Comp/Multi/Term.hs b/src/Data/Comp/Multi/Term.hs
--- a/src/Data/Comp/Multi/Term.hs
+++ b/src/Data/Comp/Multi/Term.hs
@@ -30,6 +30,13 @@
      ) where
 
 import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+import Data.Comp.Multi.Traversable
+import Data.Monoid
+
+import Control.Monad
+import Control.Applicative hiding (Const)
+
 import Unsafe.Coerce
 
 type Const (f :: (* -> *) -> * -> *) = f (K ())
@@ -78,6 +85,40 @@
     hfmap f (Hole x) = Hole (f x)
     hfmap f (Term t) = Term (hfmap (hfmap f) t)
 
+instance (HFoldable f) => HFoldable (Cxt h f) where
+    hfoldr = hfoldr' where
+        hfoldr'  :: forall a b. (a :=> b -> b) -> b -> Cxt h f a :=> b
+        hfoldr' op c a = run a c where
+              run :: (Cxt h f) a :=> b ->  b
+              run (Hole a) e = a `op` e
+              run (Term t) e = hfoldr run e t
+
+    hfoldl = hfoldl' where
+        hfoldl' :: forall a b. (b -> a :=> b) -> b -> Cxt h f a :=> b
+        hfoldl' op = run where
+              run :: b -> (Cxt h f) a :=> b
+              run e (Hole a) = e `op` a
+              run e (Term t) = hfoldl run e t
+
+    hfold (Hole (K a)) = a
+    hfold (Term t) = hfoldMap hfold t
+
+    hfoldMap = hfoldMap' where
+        hfoldMap' :: forall m a. Monoid m => (a :=> m) -> Cxt h f a :=> m
+        hfoldMap' f = run where
+              run :: Cxt h f a :=> m
+              run (Hole a) = f a
+              run (Term t) = hfoldMap run t
+
+instance (HTraversable f) => HTraversable (Cxt h f) where
+   hmapM = hmapM' where
+       hmapM' :: forall m a b. (Monad m) => NatM m a b -> NatM m (Cxt h f a) (Cxt h f b)
+       hmapM' f = run where
+             run :: NatM m (Cxt h f a) (Cxt h f b)
+             run (Hole x) = liftM Hole $ f x
+             run (Term t) = liftM Term $ hmapM run t
+   htraverse f (Hole x) = Hole <$> f x
+   htraverse f (Term t) = Term <$> htraverse (htraverse f) t
 
 simpCxt :: (HFunctor f) => f a i -> Context f a i
 simpCxt = Term . hfmap Hole
diff --git a/src/Data/Comp/Multi/Variables.hs b/src/Data/Comp/Multi/Variables.hs
--- a/src/Data/Comp/Multi/Variables.hs
+++ b/src/Data/Comp/Multi/Variables.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,
-  OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}
-
+  OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes, TemplateHaskell #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Multi.Variables
@@ -11,8 +10,9 @@
 -- Portability :  non-portable (GHC Extensions)
 --
 -- This module defines an abstract notion of (bound) variables in compositional
--- data types, and capture-avoiding substitution. All definitions are
--- generalised versions of those in "Data.Comp.Variables".
+-- data types, and scoped substitution. Capture-avoidance is /not/ taken into
+-- account. All definitions are generalised versions of those in
+-- "Data.Comp.Variables".
 --
 --------------------------------------------------------------------------------
 module Data.Comp.Multi.Variables
@@ -32,8 +32,8 @@
     ) where
 
 import Data.Comp.Multi.Term
-import Data.Comp.Multi.Sum
 import Data.Comp.Multi.Algebra
+import Data.Comp.Multi.Derive
 import Data.Comp.Multi.Functor
 import Data.Comp.Multi.Foldable
 import Data.Set (Set)
@@ -60,11 +60,7 @@
     bindsVars :: f a :=> [v]
     bindsVars _ = []
 
-instance (HasVars f v, HasVars g v) => HasVars (f :+: g) v where
-    isVar (Inl v) = isVar v
-    isVar (Inr v) = isVar v
-    bindsVars (Inl v) = bindsVars v
-    bindsVars (Inr v) = bindsVars v
+$(derive [liftSum] [''HasVars])
 
 instance HasVars f v => HasVars (Cxt h f) v where
     isVar (Term t) = isVar t
@@ -84,13 +80,13 @@
               let vars' = vars ++ bindsVars t in
               case isVar t of
                 Just v ->
-                    -- Check for capture-avoidance
+                    -- Check for scope
                     if v `elem` vars' then
-                        Term $ hfmap (\x -> unC x vars') t
+                        Term $ hfmap (`unC` vars') t
                     else
                         Hole $ K v
                 Nothing ->
-                    Term $ hfmap (\x -> unC x vars') t
+                    Term $ hfmap (`unC` vars') t
 
 containsVarAlg :: (Eq v, HasVars f v, HFoldable f) => v -> Alg f (K Bool)
 containsVarAlg v t = K $ v `notElem` bindsVars t &&
diff --git a/src/Data/Comp/MultiParam.hs b/src/Data/Comp/MultiParam.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam.hs
@@ -0,0 +1,34 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the infrastructure necessary to use
+-- /Generalised Parametric Compositional Data Types/. Generalised Parametric
+-- Compositional Data Types is an extension of Compositional Data Types with
+-- parametric higher-order abstract syntax (PHOAS) for usage with binders, and
+-- GADTs. Generalised Parametric Compositional Data Types combines Generalised
+-- Compositional Data Types ("Data.Comp.Multi") and Parametric Compositional
+-- Data Types ("Data.Comp.Param"). Examples of usage are bundled with the
+-- package in the library @examples\/Examples\/MultiParam@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam (
+    module Data.Comp.MultiParam.Term
+  , module Data.Comp.MultiParam.Algebra
+  , module Data.Comp.MultiParam.HDifunctor
+  , module Data.Comp.MultiParam.Sum
+  , module Data.Comp.MultiParam.Annotation
+  , module Data.Comp.MultiParam.Equality
+    ) where
+
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Algebra
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.Sum
+import Data.Comp.MultiParam.Annotation
+import Data.Comp.MultiParam.Equality
diff --git a/src/Data/Comp/MultiParam/Algebra.hs b/src/Data/Comp/MultiParam/Algebra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Algebra.hs
@@ -0,0 +1,339 @@
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators,
+  FlexibleContexts, CPP #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Algebra
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the notion of algebras and catamorphisms, and their
+-- generalizations to e.g. monadic versions and other (co)recursion schemes.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Algebra (
+      -- * Algebras & Catamorphisms
+      Alg,
+      free,
+      cata,
+      cata',
+      appCxt,
+      
+      -- * Monadic Algebras & Catamorphisms
+      AlgM,
+--      algM,
+      freeM,
+      cataM,
+      AlgM',
+      Compose(..),
+      freeM',
+      cataM',
+
+      -- * Term Homomorphisms
+      CxtFun,
+      SigFun,
+      TermHom,
+      appTermHom,
+      appTermHom',
+      compTermHom,
+      appSigFun,
+      appSigFun',
+      compSigFun,
+      termHom,
+      compAlg,
+
+      -- * Monadic Term Homomorphisms
+      CxtFunM,
+      SigFunM,
+      TermHomM,
+      sigFunM,
+      termHom',
+      appTermHomM,
+      appTermHomM',
+      termHomM,
+      appSigFunM,
+      appSigFunM',
+      compTermHomM,
+      compSigFunM,
+      compAlgM,
+      compAlgM'
+    ) where
+
+import Prelude hiding (sequence, mapM)
+import Control.Monad hiding (sequence, mapM)
+import Data.Functor.Compose -- Functor composition
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.HDitraversable
+
+import Unsafe.Coerce (unsafeCoerce)
+
+{-| This type represents an algebra over a difunctor @f@ and carrier @a@. -}
+type Alg f a = f a a :-> a
+
+{-| Construct a catamorphism for contexts over @f@ with holes of type @b@, from
+  the given algebra. -}
+free :: forall h f a b. HDifunctor f
+        => Alg f a -> (b :-> a) -> Cxt h f a b :-> a
+free f g = run
+    where run :: Cxt h f a b :-> a
+          run (Term t) = f (hfmap run t)
+          run (Hole x) = g x
+          run (Place p) = p
+
+{-| Construct a catamorphism from the given algebra. -}
+cata :: forall f a. HDifunctor f => Alg f a -> Term f :-> a 
+{-# NOINLINE [1] cata #-}
+cata f = run . coerceCxt
+    where run :: Trm f a :-> a
+          run (Term t) = f (hfmap run t)
+          run (Place x) = x
+
+{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where
+  the holes have the type of the algebra carrier. -}
+cata' :: HDifunctor f => Alg f a -> Cxt h f a a :-> a
+{-# INLINE cata' #-}
+cata' f = free f id
+
+{-| This function applies a whole context into another context. -}
+appCxt :: HDifunctor f => Cxt Hole f a (Cxt h f a b) :-> Cxt h f a b
+appCxt (Term t) = Term (hfmap appCxt t)
+appCxt (Hole x) = x
+appCxt (Place p) = Place p
+
+{-| This type represents a monadic algebra. It is similar to 'Alg' but
+  the return type is monadic. -}
+type AlgM m f a = NatM m (f a a) a
+
+{-| Construct a monadic catamorphism for contexts over @f@ with holes of type
+  @b@, from the given monadic algebra. -}
+freeM :: forall m h f a b. (HDitraversable f m a, Monad m)
+         => AlgM m f a -> NatM m b a -> NatM m (Cxt h f a b) a
+freeM f g = run
+    where run :: NatM m (Cxt h f a b) a
+          run (Term t) = f =<< hdimapM run t
+          run (Hole x) = g x
+          run (Place p) = return p
+
+{-| Construct a monadic catamorphism from the given monadic algebra. -}
+cataM :: forall m f a. (HDitraversable f m a, Monad m)
+         => AlgM m f a -> NatM m (Term f) a
+{-# NOINLINE [1] cataM #-}
+cataM algm = run . coerceCxt
+    where run :: NatM m (Trm f a) a
+          run (Term t) = algm =<< hdimapM run t
+          run (Place x) = return x
+
+{-| This type represents a monadic algebra, but where the covariant argument is
+  also a monadic computation. -}
+type AlgM' m f a = NatM m (f a (Compose m a)) a
+
+{-| Construct a monadic catamorphism for contexts over @f@ with holes of type
+  @b@, from the given monadic algebra. -}
+freeM' :: forall m h f a b. (HDifunctor f, Monad m)
+          => AlgM' m f a -> NatM m b a -> NatM m (Cxt h f a b) a
+freeM' f g = run
+    where run :: NatM m (Cxt h f a b) a
+          run (Term t) = f $ hfmap (Compose . run) t
+          run (Hole x) = g x
+          run (Place p) = return p
+
+{-| Construct a monadic catamorphism from the given monadic algebra. -}
+cataM' :: forall m f a. (HDifunctor f, Monad m)
+          => AlgM' m f a -> NatM m (Term f) a
+{-# NOINLINE [1] cataM' #-}
+cataM' algm = run . coerceCxt
+    where run :: NatM m (Trm f a) a
+          run (Term t) = algm $ hfmap (Compose . run) t
+          run (Place x) = return x
+
+{-| This type represents a signature function. -}
+type SigFun f g = forall a b. f a b :-> g a b
+
+{-| This type represents a context function. -}
+type CxtFun f g = forall h. SigFun (Cxt h f) (Cxt h g)
+
+{-| This type represents a term homomorphism. -}
+type TermHom f g = SigFun f (Context g)
+
+{-| Apply a term homomorphism recursively to a term/context. -}
+appTermHom :: forall f g. (HDifunctor f, HDifunctor g)
+              => TermHom f g -> CxtFun f g
+{-# INLINE [1] appTermHom #-}
+appTermHom f = run where
+    run :: CxtFun f g
+    run (Term t) = appCxt (f (hfmap run t))
+    run (Hole x) = Hole x
+    run (Place p) = Place p
+
+-- | Apply a term homomorphism recursively to a term/context. This is
+-- a top-down variant of 'appTermHom'.
+appTermHom' :: forall f g. (HDifunctor g)
+              => TermHom f g -> CxtFun f g
+{-# INLINE [1] appTermHom' #-}
+appTermHom' f = run where
+    run :: CxtFun f g
+    run (Term t) = appCxt (hfmapCxt run (f t))
+    run (Hole x) = Hole x
+    run (Place p) = Place p
+
+{-| Compose two term homomorphisms. -}
+compTermHom :: (HDifunctor g, HDifunctor h)
+               => TermHom g h -> TermHom f g -> TermHom f h
+compTermHom f g = appTermHom f . g
+
+{-| Compose an algebra with a term homomorphism to get a new algebra. -}
+compAlg :: (HDifunctor f, HDifunctor g) => Alg g a -> TermHom f g -> Alg f a
+compAlg alg talg = cata' alg . talg
+
+{-| This function applies a signature function to the given context. -}
+appSigFun :: forall f g. (HDifunctor f) => SigFun f g -> CxtFun f g
+appSigFun f = run where
+    run :: CxtFun f g
+    run (Term t) = Term (f (hfmap run t))
+    run (Hole x) = Hole x
+    run (Place p) = Place p
+
+{-| This function applies a signature function to the given context. -}
+appSigFun' :: forall f g. (HDifunctor g) => SigFun f g -> CxtFun f g
+appSigFun' f = run where
+    run :: CxtFun f g
+    run (Term t) = Term (hfmap run (f t))
+    run (Hole x) = Hole x
+    run (Place p) = Place p
+
+{-| This function composes two signature functions. -}
+compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
+compSigFun f g = f . g
+
+{-| Lifts the given signature function to the canonical term homomorphism. -}
+termHom :: HDifunctor g => SigFun f g -> TermHom f g
+termHom f = simpCxt . f
+
+{-| This type represents a monadic signature function. -}
+type SigFunM m f g = forall a b. NatM m (f a b) (g a b)
+
+{-| This type represents a monadic context function. -}
+type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g)
+
+{-| This type represents a monadic context function. -}
+type CxtFunM' m f g = forall h b . NatM m (Cxt h f Any b) (Cxt h g Any b)
+
+
+coerceCxtFunM :: CxtFunM' m f g -> CxtFunM m f g
+coerceCxtFunM = unsafeCoerce
+
+
+{-| This type represents a monadic term homomorphism. -}
+type TermHomM m f g = SigFunM m f (Cxt Hole g)
+
+
+{-| Lift the given signature function to a monadic signature function. Note that
+  term homomorphisms are instances of signature functions. Hence this function
+  also applies to term homomorphisms. -}
+sigFunM :: Monad m => SigFun f g -> SigFunM m f g
+sigFunM f = return . f
+
+{-| Lift the give monadic signature function to a monadic term homomorphism. -}
+termHom' :: (HDifunctor f, HDifunctor g, Monad m)
+            => SigFunM m f g -> TermHomM m f g
+termHom' f = liftM  (Term . hfmap Hole) . f
+
+{-| Lift the given signature function to a monadic term homomorphism. -}
+termHomM :: (HDifunctor g, Monad m) => SigFun f g -> TermHomM m f g
+termHomM f = sigFunM $ termHom f
+
+{-| Apply a monadic term homomorphism recursively to a term/context. -}
+appTermHomM :: forall f g m. (HDitraversable f m Any, HDifunctor g, Monad m)
+               => TermHomM m f g -> CxtFunM m f g
+{-# NOINLINE [1] appTermHomM #-}
+appTermHomM f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM appCxt (f =<< hdimapM run t)
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+-- | Apply a monadic term homomorphism recursively to a
+-- term/context. This is a top-down variant of 'appTermHomM'.
+appTermHomM' :: forall f g m. (HDitraversable g m Any, Monad m)
+               => TermHomM m f g -> CxtFunM m f g
+{-# NOINLINE [1] appTermHomM' #-}
+appTermHomM' f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM appCxt (hdimapMCxt run =<<  f t)
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+
+{-| This function applies a monadic signature function to the given context. -}
+appSigFunM :: forall m f g. (HDitraversable f m Any, Monad m)
+              => SigFunM m f g -> CxtFunM m f g
+appSigFunM f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM Term (f =<< hdimapM run t)
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+-- | This function applies a monadic signature function to the given
+-- context. This is a top-down variant of 'appSigFunM'.
+appSigFunM' :: forall m f g. (HDitraversable g m Any, Monad m)
+              => SigFunM m f g -> CxtFunM m f g
+appSigFunM' f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM Term (hdimapM run =<< f t)
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+
+{-| Compose two monadic term homomorphisms. -}
+compTermHomM :: (HDitraversable g m Any, HDifunctor h, Monad m)
+                => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM f g = appTermHomM f <=< g
+
+{-| Compose a monadic algebra with a monadic term homomorphism to get a new
+  monadic algebra. -}
+compAlgM :: (HDitraversable g m a, Monad m)
+            => AlgM m g a -> TermHomM m f g -> AlgM m f a
+compAlgM alg talg = freeM alg return <=< talg
+
+{-| Compose a monadic algebra with a term homomorphism to get a new monadic
+  algebra. -}
+compAlgM' :: (HDitraversable g m a, Monad m) => AlgM m g a
+          -> TermHom f g -> AlgM m f a
+compAlgM' alg talg = freeM alg return . talg
+
+{-| This function composes two monadic signature functions. -}
+compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
+compSigFunM f g a = g a >>= f
+
+
+#ifndef NO_RULES
+{-# RULES
+  "cata/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x.
+    cata a (appTermHom h x) = cata (compAlg a h) x;
+
+  "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;
+ #-}
+
+{-
+{-# RULES 
+  "cataM/appTermHomM" forall (a :: AlgM m g d) (h :: TermHomM m f g d) x.
+     appTermHomM h x >>= cataM a = cataM (compAlgM a h) x;
+
+  "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.
+     cataM a (appTermHom h x) = cataM (compAlgM' a h) x;
+
+  "appTermHomM/appTermHomM" forall (a :: TermHomM m g h b) (h :: TermHomM m f g b) x.
+    appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;
+ #-}
+
+{-# RULES
+  "cata/build"  forall alg (g :: forall a . Alg f a -> a) .
+                cata alg (build g) = g alg
+ #-}
+-}
+#endif
diff --git a/src/Data/Comp/MultiParam/Annotation.hs b/src/Data/Comp/MultiParam/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Annotation.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, RankNTypes, GADTs, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Annotation
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines annotations on signatures.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Annotation
+    (
+     (:&:) (..),
+     (:*:) (..),
+     DistAnn (..),
+     RemA (..),
+     liftA,
+     liftA',
+     stripA,
+     propAnn,
+     propAnnM,
+     ann,
+     project'
+    ) where
+
+import qualified Data.Comp.Ops as O
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Sum
+import Data.Comp.MultiParam.Ops
+import Data.Comp.MultiParam.Algebra
+
+import Control.Monad
+
+{-| Transform a function with a domain constructed from a higher-order difunctor
+  to a function with a domain constructed with the same higher-order difunctor,
+  but with an additional annotation. -}
+liftA :: (RemA s s') => (s' a b :-> t) -> s a b :-> t
+liftA f v = f (remA v)
+
+{-| Transform a function with a domain constructed from a higher-order difunctor
+  to a function with a domain constructed with the same higher-order difunctor,
+  but with an additional annotation. -}
+liftA' :: (DistAnn s' p s, HDifunctor s')
+          => (s' a b :-> Cxt h s' c d) -> s a b :-> Cxt h s c d
+liftA' f v = let v' O.:&: p = projectA v
+             in ann p (f v')
+
+{-| Strip the annotations from a term over a higher-order difunctor with
+  annotations. -}
+stripA :: (RemA g f, HDifunctor g) => CxtFun g f
+stripA = appSigFun remA
+
+{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism
+ over the same signatures, but extended with annotations. -}
+propAnn :: (DistAnn f p f', DistAnn g p g', HDifunctor g) 
+           => TermHom f g -> TermHom f' g'
+propAnn hom f' = ann p (hom f)
+    where f O.:&: p = projectA f'
+
+{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic
+  term homomorphism over the same signatures, but extended with annotations. -}
+propAnnM :: (DistAnn f p f', DistAnn g p g', HDifunctor g, Monad m)
+         => TermHomM m f g -> TermHomM m f' g'
+propAnnM hom f' = liftM (ann p) (hom f)
+    where f O.:&: p = projectA f'
+
+{-| Annotate each node of a term with a constant value. -}
+ann :: (DistAnn f p g, HDifunctor f) => p -> CxtFun f g
+ann c = appSigFun (injectA c)
+
+{-| This function is similar to 'project' but applies to signatures
+  with an annotation which is then ignored. -}
+-- bug in type checker? below is the inferred type, however, the type checker
+-- rejects it.
+-- project' :: (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))
+project' v = liftM remA $ project v
diff --git a/src/Data/Comp/MultiParam/Any.hs b/src/Data/Comp/MultiParam/Any.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Any.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE EmptyDataDecls, KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Any
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the empty data type 'Any', which is used to emulate
+-- parametricity (\"poor mans parametricity\").
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Any
+    (
+     Any
+    ) where
+
+-- |The empty data type 'Any' is used to emulate parametricity
+-- (\"poor mans parametricity\").
+data Any :: * -> *
diff --git a/src/Data/Comp/MultiParam/Derive.hs b/src/Data/Comp/MultiParam/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive.hs
@@ -0,0 +1,51 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module contains functionality for automatically deriving boilerplate
+-- code using Template Haskell. Examples include instances of 'HDifunctor',
+-- 'ShowHD', and 'EqHD'.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive
+    (
+     derive,
+     -- |Derive boilerplate instances for parametric signatures, i.e.
+     -- signatures for parametric compositional data types.
+
+     -- ** EqHD
+     module Data.Comp.MultiParam.Derive.Equality,
+     -- ** OrdHD
+     module Data.Comp.MultiParam.Derive.Ordering,
+     -- ** ShowHD
+     module Data.Comp.MultiParam.Derive.Show,
+     -- ** HDifunctor
+     module Data.Comp.MultiParam.Derive.HDifunctor,
+     -- ** HFoldable
+     module Data.Comp.Multi.Derive.Foldable,
+     -- ** HTraversable
+     module Data.Comp.Multi.Derive.Traversable,
+     -- ** Smart Constructors
+     module Data.Comp.MultiParam.Derive.SmartConstructors,
+     -- ** Smart Constructors w/ Annotations
+     module Data.Comp.MultiParam.Derive.SmartAConstructors,
+     -- ** Lifting to Sums
+     module Data.Comp.MultiParam.Derive.LiftSum
+    ) where
+
+import Data.Comp.Derive.Utils (derive)
+import Data.Comp.MultiParam.Derive.Equality
+import Data.Comp.MultiParam.Derive.Ordering
+import Data.Comp.MultiParam.Derive.Show
+import Data.Comp.MultiParam.Derive.HDifunctor
+import Data.Comp.Multi.Derive.Foldable
+import Data.Comp.Multi.Derive.Traversable
+import Data.Comp.MultiParam.Derive.SmartConstructors
+import Data.Comp.MultiParam.Derive.SmartAConstructors
+import Data.Comp.MultiParam.Derive.LiftSum
diff --git a/src/Data/Comp/MultiParam/Derive/Equality.hs b/src/Data/Comp/MultiParam/Derive/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/Equality.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
+  ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.Equality
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @EqHD@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.Derive.Equality
+    (
+     EqHD(..),
+     makeEqHD
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.MultiParam.FreshM
+import Data.Comp.MultiParam.Equality
+import Control.Monad
+import Language.Haskell.TH hiding (Cxt, match)
+
+{-| Derive an instance of 'EqHD' for a type constructor of any parametric
+  kind taking at least three arguments. -}
+makeEqHD :: Name -> Q [Dec]
+makeEqHD fname = do
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+  -- covariant argument
+  let coArg :: Name = tyVarBndrName $ last args'
+  -- contravariant argument
+  let conArg :: Name = tyVarBndrName $ last $ init args'
+  let argNames = map (VarT . tyVarBndrName) (init $ init args')
+  let complType = foldl AppT (ConT name) argNames
+  let classType = AppT (ConT ''EqHD) complType
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  let defC = if length constrs < 2 then
+                 []
+             else
+                 [clause [wildP,wildP] (normalB [|return False|]) []]
+  eqHDDecl <- funD 'eqHD (map (eqHDClause conArg coArg) constrs' ++ defC)
+  return [InstanceD [] classType [eqHDDecl]]
+      where eqHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            eqHDClause conArg coArg (constr, args) = do
+              varXs <- newNames (length args) "x"
+              varYs <- newNames (length args) "y"
+              -- Patterns for the constructors
+              let patx = ConP constr $ map VarP varXs
+              let paty = ConP constr $ map VarP varYs
+              body <- eqHDBody conArg coArg (zip3 varXs varYs args)
+              return $ Clause [patx,paty] (NormalB body) []
+            eqHDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ
+            eqHDBody conArg coArg x =
+                [|liftM and (sequence $(listE $ map (eqHDB conArg coArg) x))|]
+            eqHDB :: Name -> Name -> (Name, Name, Type) -> ExpQ
+            eqHDB conArg coArg (x, y, tp)
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) =
+                    [| return $ $(varE x) == $(varE y) |]
+                | otherwise =
+                    case tp of
+                      AppT (VarT a) _ 
+                          | a == coArg -> [| peq $(varE x) $(varE y) |]
+                      AppT (AppT ArrowT (AppT (VarT a) _)) _
+                          | a == conArg ->
+                              [| do {v <- genVar;
+                                     peq ($(varE x) $ varCoerce v) 
+                                         ($(varE y) $ varCoerce v)} |]
+                      SigT tp' _ ->
+                          eqHDB conArg coArg (x, y, tp')
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| eqHD $(varE x) $(varE y) |]
+                          else
+                              [| peq $(varE x) $(varE y) |]
diff --git a/src/Data/Comp/MultiParam/Derive/HDifunctor.hs b/src/Data/Comp/MultiParam/Derive/HDifunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/HDifunctor.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.HDifunctor
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HDifunctor@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive.HDifunctor
+    (
+     HDifunctor,
+     makeHDifunctor
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.MultiParam.HDifunctor
+import Language.Haskell.TH
+
+{-| Derive an instance of 'HDifunctor' for a type constructor of any parametric
+  kind taking at least three arguments. -}
+makeHDifunctor :: Name -> Q [Dec]
+makeHDifunctor fname = do
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+  -- covariant argument
+  let coArg :: Name = tyVarBndrName $ last args'
+  -- contravariant argument
+  let conArg :: Name = tyVarBndrName $ last $ init args'
+  let argNames = map (VarT . tyVarBndrName) (init $ init args')
+  let complType = foldl AppT (ConT name) argNames
+  let classType = AppT (ConT ''HDifunctor) complType
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  hdimapDecl <- funD 'hdimap (map (hdimapClause conArg coArg) constrs')
+  return [InstanceD [] classType [hdimapDecl]]
+      where hdimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            hdimapClause conArg coArg (constr, args) = do
+              fn <- newName "_f"
+              gn <- newName "_g"
+              varNs <- newNames (length args) "x"
+              let f = varE fn
+              let g = varE gn
+              let fp = VarP fn
+              let gp = VarP gn
+              -- Pattern for the constructor
+              let pat = ConP constr $ map VarP varNs
+              body <- hdimapArgs conArg coArg f g (zip varNs args) (conE constr)
+              return $ Clause [fp, gp, pat] (NormalB body) []
+            hdimapArgs :: Name -> Name -> ExpQ -> ExpQ
+                      -> [(Name, Type)] -> ExpQ -> ExpQ
+            hdimapArgs _ _ _ _ [] acc =
+                acc
+            hdimapArgs conArg coArg f g ((x,tp):tps) acc =
+                hdimapArgs conArg coArg f g tps
+                          (acc `appE` (hdimapArg conArg coArg tp f g `appE` varE x))
+            hdimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ
+            hdimapArg conArg coArg tp f g
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) = [| id |]
+                | otherwise =
+                    case tp of
+                      AppT (VarT a) _ | a == conArg -> f
+                                      | a == coArg -> g
+                      AppT (AppT ArrowT tp1) tp2 -> do
+                          xn <- newName "x"
+                          let ftp1 = hdimapArg conArg coArg tp1 f g
+                          let ftp2 = hdimapArg conArg coArg tp2 f g
+                          lamE [varP xn]
+                               (infixE (Just ftp2)
+                                       [|(.)|]
+                                       (Just $ infixE (Just $ varE xn)
+                                                      [|(.)|]
+                                                      (Just ftp1)))
+                      SigT tp' _ ->
+                          hdimapArg conArg coArg tp' f g
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| hdimap $f $g |]
+                          else
+                              [| fmap $g |]
diff --git a/src/Data/Comp/MultiParam/Derive/Injections.hs b/src/Data/Comp/MultiParam/Derive/Injections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/Injections.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.Injections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature injections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive.Injections
+    (
+     injn,
+     injectn,
+     deepInjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Algebra (CxtFun, appSigFun)
+import Data.Comp.MultiParam.Ops ((:+:)(..), (:<:)(..))
+
+injn :: Int -> Q [Dec]
+injn n = do
+  let i = mkName $ "inj" ++ show n
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let ivar = mkName "i"
+  let xvar = mkName "x"
+  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar bvar ivar) : d
+    where genSig fvars gvar avar bvar ivar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = arrowT `appT` (tp `appT` varT avar `appT`
+                                     varT bvar `appT` varT ivar)
+                             `appT` (varT gvar `appT` varT avar `appT`
+                                     varT bvar `appT` varT ivar)
+            forallT (map PlainTV $ gvar : avar : bvar : ivar : fvars)
+                    (sequence cxt) tp'
+          genDecl x n = [| case $(varE x) of
+                             Inl x -> $(varE $ mkName $ "inj") x
+                             Inr x -> $(varE $ mkName $ "inj" ++
+                                        if n > 2 then show (n - 1) else "") x |]
+injectn :: Int -> Q [Dec]
+injectn n = do
+  let i = mkName ("inject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let ivar = mkName "i"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar bvar ivar) : d
+    where genSig fvars gvar avar bvar ivar = do
+            let hvar = mkName "h"
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar
+                                 `appT` varT avar `appT` varT bvar
+            let tp'' = arrowT `appT` (tp `appT` varT avar `appT`
+                                      tp' `appT` varT ivar)
+                              `appT` (tp' `appT` varT ivar)
+            forallT (map PlainTV $ hvar : gvar : avar : bvar : ivar : fvars)
+                    (sequence cxt) tp''
+          genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]
+
+deepInjectn :: Int -> Q [Dec]
+deepInjectn n = do
+  let i = mkName ("deepInject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar) : d
+    where genSig fvars gvar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let cxt' = classP ''HDifunctor [tp]
+            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar
+            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
diff --git a/src/Data/Comp/MultiParam/Derive/LiftSum.hs b/src/Data/Comp/MultiParam/Derive/LiftSum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/LiftSum.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.LiftSum
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Lift a class declaration for higher-order difunctors to sums of higher-order
+-- difunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive.LiftSum
+    (
+     liftSum,
+     caseHD
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.MultiParam.Sum
+import Data.Comp.MultiParam.Ops ((:+:)(..))
+
+{-| Given the name of a type class, where the first parameter is a higher-order
+  difunctor, lift it to sums of higher-order difunctors. Example:
+  @class ShowHD f where ...@ is lifted as
+  @instance (ShowHD f, ShowHD g) => ShowHD (f :+: g) where ... @. -}
+liftSum :: Name -> Q [Dec]
+liftSum fname = do
+  ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname
+  let targs' = map tyVarBndrName $ tail targs
+  let f = mkName "f"
+  let g = mkName "g"
+  let cxt = [ClassP name (map VarT $ f : targs'),
+             ClassP name (map VarT $ g : targs')]
+  let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)
+  let complType = foldl (\a x -> a `AppT` VarT x) tp targs'
+  decs' <- sequence $ concatMap decl decs
+  return [InstanceD cxt complType decs']
+      where decl :: Dec -> [DecQ]
+            decl (SigD f _) = [funD f [clause f]]
+            decl _ = []
+            clause :: Name -> ClauseQ
+            clause f = do x <- newName "x"
+                          b <- normalB [|caseHD $(varE f) $(varE f) $(varE x)|]
+                          return $ Clause [VarP x] b []
+
+{-| Utility function to case on a higher-order difunctor sum, without exposing
+  the internal representation of sums. -}
+caseHD :: (f a b i -> c) -> (g a b i -> c) -> (f :+: g) a b i -> c
+caseHD f g x = case x of
+                 Inl x -> f x
+                 Inr x -> g x
diff --git a/src/Data/Comp/MultiParam/Derive/Ordering.hs b/src/Data/Comp/MultiParam/Derive/Ordering.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/Ordering.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
+  ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.Ordering
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @OrdHD@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.Derive.Ordering
+    (
+     OrdHD(..),
+     makeOrdHD
+    ) where
+
+import Data.Comp.MultiParam.FreshM
+import Data.Comp.MultiParam.Ordering
+import Data.Comp.Derive.Utils
+import Data.Maybe
+import Data.List
+import Language.Haskell.TH hiding (Cxt)
+import Control.Monad (liftM)
+
+compList :: [Ordering] -> Ordering
+compList = fromMaybe EQ . find (/= EQ)
+
+{-| Derive an instance of 'OrdHD' for a type constructor of any parametric
+  kind taking at least three arguments. -}
+makeOrdHD :: Name -> Q [Dec]
+makeOrdHD fname = do
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+  -- covariant argument
+  let coArg :: Name = tyVarBndrName $ last args'
+  -- contravariant argument
+  let conArg :: Name = tyVarBndrName $ last $ init args'
+  let argNames = map (VarT . tyVarBndrName) (init $ init args')
+  let complType = foldl AppT (ConT name) argNames
+  let classType = AppT (ConT ''OrdHD) complType
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  compareHDDecl <- funD 'compareHD (compareHDClauses conArg coArg constrs')
+  return [InstanceD [] classType [compareHDDecl]]
+      where compareHDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ]
+            compareHDClauses _ _ [] = []
+            compareHDClauses conArg coArg constrs = 
+                let constrs' = constrs `zip` [1..]
+                    constPairs = [(x,y)| x<-constrs', y <- constrs']
+                in map (genClause conArg coArg) constPairs
+            genClause conArg coArg ((c,n),(d,m))
+                | n == m = genEqClause conArg coArg c
+                | n < m = genLtClause c d
+                | otherwise = genGtClause c d
+            genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            genEqClause conArg coArg (constr, args) = do 
+              varXs <- newNames (length args) "x"
+              varYs <- newNames (length args) "y"
+              let patX = ConP constr $ map VarP varXs
+              let patY = ConP constr $ map VarP varYs
+              body <- eqDBody conArg coArg (zip3 varXs varYs args)
+              return $ Clause [patX, patY] (NormalB body) []
+            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ
+            eqDBody conArg coArg x =
+                [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]
+            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ
+            eqDB conArg coArg (x, y, tp)
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) =
+                    [| return $ compare $(varE x) $(varE y) |]
+                | otherwise =
+                    case tp of
+                      AppT (VarT a) _ 
+                          | a == coArg -> [| pcompare $(varE x) $(varE y) |]
+                      AppT (AppT ArrowT (AppT (VarT a) _)) _
+                          | a == conArg ->
+                              [| do {v <- genVar;
+                                     pcompare ($(varE x) $ varCoerce v)
+                                              ($(varE y) $ varCoerce v)} |]
+                      SigT tp' _ ->
+                          eqDB conArg coArg (x, y, tp')
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| compareHD $(varE x) $(varE y) |]
+                          else
+                              [| pcompare $(varE x) $(varE y) |]
+            genLtClause (c, _) (d, _) =
+                clause [recP c [], recP d []] (normalB [| return LT |]) []
+            genGtClause (c, _) (d, _) =
+                clause [recP c [], recP d []] (normalB [| return GT |]) []
diff --git a/src/Data/Comp/MultiParam/Derive/Projections.hs b/src/Data/Comp/MultiParam/Derive/Projections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/Projections.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE TemplateHaskell, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.Projections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature projections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive.Projections
+    (
+     projn,
+     projectn,
+     deepProjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Control.Monad (liftM)
+import Data.Comp.MultiParam.HDitraversable (HDitraversable)
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Algebra (CxtFunM, appSigFunM')
+import Data.Comp.MultiParam.Ops ((:+:)(..), (:<:)(..))
+
+projn :: Int -> Q [Dec]
+projn n = do
+  let p = mkName $ "proj" ++ show n
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let ivar = mkName "i"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar bvar ivar) []]]
+  sequence $ (sigD p $ genSig gvars avar bvar ivar) : d
+    where genSig gvars avar bvar ivar = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = arrowT `appT` (varT fvar `appT` varT avar `appT`
+                                     varT bvar `appT` varT ivar)
+                             `appT` (conT ''Maybe `appT`
+                                     (tp `appT` varT avar `appT`
+                                      varT bvar `appT` varT ivar))
+            forallT (map PlainTV $ fvar : avar : bvar : ivar : gvars)
+                    (sequence cxt) tp'
+          genDecl x [g] a b i =
+            [| liftM inj (proj $(varE x)
+                          :: Maybe ($(varT g `appT` varT a `appT`
+                                      varT b `appT` varT i))) |]
+          genDecl x (g:gs) a b i =
+            [| case (proj $(varE x)
+                         :: Maybe ($(varT g `appT` varT a `appT`
+                                     varT b `appT` varT i))) of
+                 Just y -> Just $ inj y
+                 _ -> $(genDecl x gs a b i) |]
+          genDecl _ _ _ _ _ = error "genDecl called with empty list"
+
+projectn :: Int -> Q [Dec]
+projectn n = do
+  let p = mkName ("project" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let ivar = mkName "i"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD p $ genSig gvars avar bvar ivar) : d
+    where genSig gvars avar bvar ivar = do
+            let fvar = mkName "f"
+            let hvar = mkName "h"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar
+                                 `appT` varT avar `appT` varT bvar
+            let tp'' = arrowT `appT` (tp' `appT` varT ivar)
+                              `appT` (conT ''Maybe `appT`
+                                      (tp `appT` varT avar `appT` tp' `appT`
+                                       varT ivar))
+            forallT (map PlainTV $ hvar : fvar : avar : bvar : ivar : gvars)
+                    (sequence cxt) tp''
+          genDecl x n = [| case $(varE x) of
+                             Hole _ -> Nothing
+                             Place _ -> Nothing
+                             Term t -> $(varE $ mkName $ "proj" ++ show n) t |]
+
+deepProjectn :: Int -> Q [Dec]
+deepProjectn n = do
+  let p = mkName ("deepProject" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let d = [funD p [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD p $ genSig gvars) : d
+    where genSig gvars = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let cxt' = classP ''HDitraversable [tp, conT ''Maybe, conT ''Any]
+            let tp' = conT ''CxtFunM `appT` conT ''Maybe
+                                     `appT` varT fvar `appT` tp
+            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
diff --git a/src/Data/Comp/MultiParam/Derive/Show.hs b/src/Data/Comp/MultiParam/Derive/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/Show.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
+  ScopedTypeVariables, UndecidableInstances, KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.Show
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @ShowHD@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.Derive.Show
+    (
+     PShow(..),
+     ShowHD(..),
+     makeShowHD
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.MultiParam.FreshM
+import Control.Monad
+import Language.Haskell.TH hiding (Cxt, match)
+
+-- |Printing of parametric values.
+class PShow a where
+    pshow :: a i -> FreshM String
+
+{-| Signature printing. An instance @ShowHD f@ gives rise to an instance
+  @Show (Term f i)@. -}
+class ShowHD f where
+    showHD :: PShow a => f Var a i -> FreshM String
+
+{-| Derive an instance of 'ShowHD' for a type constructor of any parametric
+  kind taking at least three arguments. -}
+makeShowHD :: Name -> Q [Dec]
+makeShowHD fname = do
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+  -- covariant argument
+  let coArg :: Name = tyVarBndrName $ last args'
+  -- contravariant argument
+  let conArg :: Name = tyVarBndrName $ last $ init args'
+  let argNames = map (VarT . tyVarBndrName) (init $ init args')
+  let complType = foldl AppT (ConT name) argNames
+  let classType = AppT (ConT ''ShowHD) complType
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  showHDDecl <- funD 'showHD (map (showHDClause conArg coArg) constrs')
+  return [InstanceD [] classType [showHDDecl]]
+      where showHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            showHDClause conArg coArg (constr, args) = do
+              varXs <- newNames (length args) "x"
+              -- Pattern for the constructor
+              let patx = ConP constr $ map VarP varXs
+              body <- showHDBody (nameBase constr) conArg coArg (zip varXs args)
+              return $ Clause [patx] (NormalB body) []
+            showHDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ
+            showHDBody constr conArg coArg x =
+                [|liftM (unwords . (constr :) .
+                         map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x))
+                        (sequence $(listE $ map (showHDB conArg coArg) x))|]
+            showHDB :: Name -> Name -> (Name, Type) -> ExpQ
+            showHDB conArg coArg (x, tp)
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) =
+                    [| return $ show $(varE x) |]
+                | otherwise =
+                    case tp of
+                      AppT (VarT a) _ 
+                          | a == coArg -> [| pshow $(varE x) |]
+                      AppT (AppT ArrowT (AppT (VarT a) _)) _
+                          | a == conArg ->
+                              [| do {v <- genVar;
+                                     body <- pshow $ $(varE x) v;
+                                     return $ "\\" ++ varShow v ++ " -> " ++ body} |]
+                      SigT tp' _ ->
+                          showHDB conArg coArg (x, tp')
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| showHD $(varE x) |]
+                          else
+                              [| pshow $(varE x) |]
diff --git a/src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs b/src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.SmartAConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors with annotations.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive.SmartAConstructors 
+    (
+     smartAConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.MultiParam.Ops
+import Data.Comp.MultiParam.Term
+
+import Control.Monad
+
+{-| Derive smart constructors with products for a type constructor of any
+  parametric kind taking at least three arguments. The smart constructors are
+  similar to the ordinary constructors, but an 'injectA' is automatically
+  inserted. -}
+smartAConstructors :: Name -> Q [Dec]
+smartAConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let cons = map abstractConType constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where genSmartConstr targs tname (name, args) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args
+              genSmartConstr' targs tname sname name args = do
+                varNs <- newNames args "x"
+                varPr <- newName "_p"
+                let pats = map varP (varPr : varNs)
+                    vars = map varE varNs
+                    val = appE [|injectA $(varE varPr)|] $
+                          appE [|inj|] $ foldl appE (conE name) vars
+                    function = [funD sname [clause pats (normalB [|Term $val|]) []]]
+                sequence function
diff --git a/src/Data/Comp/MultiParam/Derive/SmartConstructors.hs b/src/Data/Comp/MultiParam/Derive/SmartConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Derive/SmartConstructors.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Derive.SmartConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors for parametric types.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Derive.SmartConstructors 
+    (
+     smartConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.MultiParam.Sum
+import Data.Comp.MultiParam.Term
+import Control.Monad
+
+{-| Derive smart constructors for a type constructor of any parametric kind
+ taking at least three arguments. The smart constructors are similar to the
+ ordinary constructors, but an 'inject' is automatically inserted. -}
+smartConstructors :: Name -> Q [Dec]
+smartConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let iVar = tyVarBndrName $ last targs
+    let cons = map (\con -> (abstractConType con, iTp iVar con)) constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where iTp iVar (ForallC _ cxt _) =
+                  -- Check if the GADT phantom type is constrained
+                  case [y | EqualP x y <- cxt, x == VarT iVar] of
+                    [] -> Nothing
+                    tp:_ -> Just tp
+              iTp _ _ = Nothing
+              genSmartConstr targs tname ((name, args), miTp) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ 'i' : bname) name args miTp
+              genSmartConstr' targs tname sname name args miTp = do
+                varNs <- newNames args "x"
+                let pats = map varP varNs
+                    vars = map varE varNs
+                    val = foldl appE (conE name) vars
+                    sig = genSig targs tname sname args miTp
+                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]
+                sequence $ sig ++ function
+              genSig targs tname sname 0 miTp = (:[]) $ do
+                hvar <- newName "h"
+                fvar <- newName "f"
+                avar <- newName "a"
+                bvar <- newName "b"
+                ivar <- newName "i"
+                let targs' = init $ init $ init $ targs
+                    vars = hvar:fvar:avar:bvar:(maybe [ivar] (const []) miTp)++targs'
+                    h = varT hvar
+                    f = varT fvar
+                    a = varT avar
+                    b = varT bvar
+                    i = varT ivar
+                    ftype = foldl appT (conT tname) (map varT targs')
+                    constr = classP ''(:<:) [ftype, f]
+                    typ = foldl appT (conT ''Cxt) [h, f, a, b,maybe i return miTp]
+                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ
+                sigD sname typeSig
+              genSig _ _ _ _ _ = []
diff --git a/src/Data/Comp/MultiParam/Desugar.hs b/src/Data/Comp/MultiParam/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Desugar.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, OverlappingInstances, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Desugar
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This modules defines the 'Desugar' type class for desugaring of terms.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Desugar where
+
+import Data.Comp.MultiParam
+import Data.Comp.MultiParam.Derive
+
+-- |The desugaring term homomorphism.
+class (HDifunctor f, HDifunctor g) => Desugar f g where
+    desugHom :: TermHom f g
+    desugHom = desugHom' . hfmap Hole
+    desugHom' :: f a (Cxt h g a b) :-> Cxt h g a b
+    desugHom' x = appCxt (desugHom x)
+
+$(derive [liftSum] [''Desugar])
+
+-- |Desugar a term.
+desugar :: Desugar f g => Term f :-> Term g
+desugar = appTermHom desugHom
+
+-- |Lift desugaring to annotated terms.
+desugarA :: (HDifunctor f', HDifunctor g', DistAnn f p f', DistAnn g p g',
+             Desugar f g) => Term f' :-> Term g'
+desugarA = appTermHom (propAnn desugHom)
+
+-- |Default desugaring instance.
+instance (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g where
+    desugHom = simpCxt . inj
diff --git a/src/Data/Comp/MultiParam/Equality.hs b/src/Data/Comp/MultiParam/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Equality.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,
+  UndecidableInstances, IncoherentInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Equality
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines equality for signatures, which lifts to equality for
+-- terms.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.Equality
+    (
+     PEq(..),
+     EqHD(..)
+    ) where
+
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Sum
+import Data.Comp.MultiParam.Ops
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.FreshM
+
+-- |Equality on parametric values. The equality test is performed inside the
+-- 'FreshM' monad for generating fresh identifiers.
+class PEq a where
+    peq :: a i -> a j -> FreshM Bool
+
+instance Eq a => PEq (K a) where
+    peq (K x) (K y) = return $ x == y
+
+{-| Signature equality. An instance @EqHD f@ gives rise to an instance
+  @Eq (Term f i)@. The equality test is performed inside the 'FreshM' monad for
+  generating fresh identifiers. -}
+class EqHD f where
+    eqHD :: PEq a => f Var a i -> f Var a j -> FreshM Bool
+
+{-| 'EqHD' is propagated through sums. -}
+instance (EqHD f, EqHD g) => EqHD (f :+: g) where
+    eqHD (Inl x) (Inl y) = eqHD x y
+    eqHD (Inr x) (Inr y) = eqHD x y
+    eqHD _ _ = return False
+
+instance PEq Var where
+   peq x y = return $ varEq x y
+
+{-| From an 'EqHD' difunctor an 'Eq' instance of the corresponding term type can
+  be derived. -}
+instance EqHD f => EqHD (Cxt h f) where
+    eqHD (Term e1) (Term e2) = eqHD e1 e2
+    eqHD (Hole h1) (Hole h2) = peq h1 h2
+    eqHD (Place p1) (Place p2) = peq p1 p2
+    eqHD _ _ = return False
+
+instance (EqHD f, PEq a) => PEq (Cxt h f Var a) where
+    peq = eqHD
+
+{-| Equality on terms. -}
+instance (HDifunctor f, EqHD f) => Eq (Term f i) where
+    (==) x y = evalFreshM $ eqHD (coerceCxt x) (coerceCxt y)
diff --git a/src/Data/Comp/MultiParam/FreshM.hs b/src/Data/Comp/MultiParam/FreshM.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/FreshM.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.FreshM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines a monad for generating fresh, abstract variables, useful
+-- e.g. for defining equality on terms.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.FreshM
+    (
+     FreshM,
+     Var,
+     varEq,
+     varCompare,
+     varShow,
+     genVar,
+     varCoerce,
+     evalFreshM
+    ) where
+
+import Control.Monad.State
+
+-- |Monad for generating fresh (abstract) variables.
+newtype FreshM a = FreshM (State [String] a)
+    deriving Monad
+
+-- |Abstract notion of a variable (the constructor is hidden).
+data Var i = Var String
+
+-- |Equality on variables.
+varEq :: Var i -> Var j -> Bool
+varEq (Var x) (Var y) = x == y
+
+-- |Ordering of variables.
+varCompare :: Var i -> Var j -> Ordering
+varCompare (Var x) (Var y) = compare x y
+
+-- |Printing of variables.
+varShow :: Var i -> String
+varShow (Var x) = x
+
+-- |Change the type of a variable.
+varCoerce :: Var i -> Var j
+varCoerce (Var x) = Var x
+
+-- |Generate a fresh variable.
+genVar :: FreshM (Var i)
+genVar = FreshM $ do xs <- get
+                     case xs of
+                       (x : xs') -> do {put xs'; return $ Var x}
+                       _ -> fail "Unexpected empty list"
+
+-- |Evaluate a computation that uses fresh variables.
+evalFreshM :: FreshM a -> a
+evalFreshM (FreshM m) = evalState m vars
+    where baseVars = ['a'..'z']
+          vars = map (:[]) baseVars ++ vars' 1
+          vars' n = map (: show n) baseVars ++ vars' (n + 1)
diff --git a/src/Data/Comp/MultiParam/HDifunctor.hs b/src/Data/Comp/MultiParam/HDifunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/HDifunctor.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RankNTypes,
+  TypeOperators, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.HDifunctor
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines higher-order difunctors, a hybrid between higher-order
+-- functors (Johann, Ghani, POPL '08), and difunctors (Meijer, Hutton, FPCA
+-- '95). Higher-order difunctors are used to define signatures for
+-- compositional parametric generalised data types.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.HDifunctor
+    (
+     HDifunctor (..),
+     HFunctor (..),
+     I (..),
+     K (..),
+     A (..),
+     (:->),
+     NatM
+    ) where
+
+import Data.Comp.Multi.Functor (HFunctor (..))
+
+-- | The identity functor.
+data I a = I {unI :: a}
+
+-- | The parametrised constant functor.
+data K a i = K {unK :: a}
+
+instance Functor I where
+    fmap f (I x) = I (f x)
+
+instance Functor (K a) where
+    fmap _ (K x) = K x
+
+data A f = forall i. A {unA :: f i}
+
+instance Eq a => Eq (K a i) where
+    K x == K y = x == y
+    K x /= K y = x /= y
+
+instance Ord a => Ord (K a i) where
+    K x < K y = x < y
+    K x > K y = x > y
+    K x <= K y = x <= y
+    K x >= K y = x >= y
+    min (K x) (K y) = K $ min x y
+    max (K x) (K y) = K $ max x y
+    compare (K x) (K y) = compare x y
+
+infixr 0 :-> -- same precedence as function space operator ->
+
+-- |This type represents natural transformations.
+type f :-> g = forall i . f i -> g i
+
+-- |This type represents monadic natural transformations.
+type NatM m f g = forall i. f i -> m (g i)
+
+-- | This class represents higher-order difunctors.
+class HDifunctor f where
+    hdimap :: (a :-> b) -> (c :-> d) -> f b c :-> f a d
+
+-- |A higher-order difunctor gives rise to a higher-order functor when
+-- restricted to a particular contravariant argument.
+instance HDifunctor f => HFunctor (f a) where
+    hfmap = hdimap id
diff --git a/src/Data/Comp/MultiParam/HDitraversable.hs b/src/Data/Comp/MultiParam/HDitraversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/HDitraversable.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses,
+  FlexibleContexts, OverlappingInstances, TypeOperators, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.HDitraversable
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines traversable higher-order difunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.HDitraversable
+    (
+     HDitraversable (..),
+     HTraversable (..)
+    ) where
+
+import Prelude hiding (mapM, sequence, foldr)
+import Data.Comp.Multi.Traversable
+import Data.Comp.MultiParam.HDifunctor
+{-import Data.Traversable
+import Test.QuickCheck.Gen
+import Data.Functor.Identity
+import Control.Monad.Reader hiding (mapM, sequence)-}
+
+{-| HDifunctors representing data structures that can be traversed from left to
+  right. -}
+class (HDifunctor f, Monad m) => HDitraversable f m a where
+    hdimapM :: NatM m b c -> NatM m (f a b) (f a c)
+
+{-| If a higher-order difunctor is 'HTraversable' for a given contravariant
+  argument @a@, then it is 'HDitraversable' for all 'Monad's @m@ with the same
+  @a@. -}
+instance (HDifunctor f, Monad m, HTraversable (f a)) => HDitraversable f m a where
+    hdimapM = hmapM
+
+{-instance HDitraversable (:~>) Gen a where
+    hdimapM f ((:~>) s) = MkGen run
+        where run stdGen seed a = unGen (f (s a)) stdGen seed
+
+instance HDitraversable (->) Identity a where
+    dimapM f s = Identity run
+        where run a = runIdentity (f (s a))
+    disequence s = Identity run
+        where run a = runIdentity (s a)
+
+instance HDitraversable (->) m a =>  HDitraversable (->) (ReaderT r m) a where
+    dimapM f s = ReaderT (disequence . run)
+        where run r a = runReaderT (f (s a)) r
+    disequence s = ReaderT (disequence . run)
+        where run r a = runReaderT (s a) r
+
+{-| Functions of the type @Any -> Maybe a@ can be turned into functions of
+ type @Maybe (Any -> a)@. The empty type @Any@ ensures that the function
+ is parametric in the input, and hence the @Maybe@ monad can be pulled out. -}
+instance HDitraversable (->) Maybe Any where
+    disequence f = do _ <- f undefined
+                      return $ \x -> fromJust $ f x-}
diff --git a/src/Data/Comp/MultiParam/Ops.hs b/src/Data/Comp/MultiParam/Ops.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Ops.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies,
+  FlexibleInstances, UndecidableInstances, IncoherentInstances,
+  KindSignatures #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Ops
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides operators on higher-order difunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Ops where
+
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.HDitraversable
+import qualified Data.Comp.Ops as O
+import Control.Monad (liftM)
+
+
+-- Sums
+infixr 6 :+:
+
+-- |Formal sum of signatures (difunctors).
+data (f :+: g) (a :: * -> *) (b :: * -> *) i = Inl (f a b i)
+                                             | Inr (g a b i)
+
+instance (HDifunctor f, HDifunctor g) => HDifunctor (f :+: g) where
+    hdimap f g (Inl e) = Inl (hdimap f g e)
+    hdimap f g (Inr e) = Inr (hdimap f g e)
+
+instance (HDitraversable f m a, HDitraversable g m a)
+    => HDitraversable (f :+: g) m a where
+    hdimapM f (Inl e) = Inl `liftM` hdimapM f e
+    hdimapM f (Inr e) = Inr `liftM` hdimapM f e
+
+-- | Signature containment relation for automatic injections. The left-hand must
+-- be an atomic signature, where as the right-hand side must have a list-like
+-- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@,
+-- non-examples include @f :+: g :<: f :+: (g :+: h)@ and
+-- @f :<: (f :+: g) :+: h@.
+class (sub :: (* -> *) -> (* -> *) -> * -> *) :<: sup where
+    inj :: sub a b :-> sup a b
+    proj :: NatM Maybe (sup a b) (sub a b)
+
+instance (:<:) f f where
+    inj = id
+    proj = Just
+
+instance (:<:) f (f :+: g) where
+    inj = Inl
+    proj (Inl x) = Just x
+    proj (Inr _) = Nothing
+
+instance (f :<: g) => (:<:) f (h :+: g) where
+    inj = Inr . inj
+    proj (Inr x) = proj x
+    proj (Inl _) = Nothing
+
+
+-- Products
+infixr 8 :*:
+
+-- |Formal product of signatures (higher-order difunctors).
+data (f :*: g) a b = f a b :*: g a b
+
+ffst :: (f :*: g) a b -> f a b
+ffst (x :*: _) = x
+
+fsnd :: (f :*: g) a b -> g a b
+fsnd (_ :*: x) = x
+
+
+-- Constant Products
+infixr 7 :&:
+
+{-| This data type adds a constant product to a signature. -}
+data (f :&: p) (a :: * -> *) (b :: * -> *) i = f a b i :&: p
+
+instance HDifunctor f => HDifunctor (f :&: p) where
+    hdimap f g (v :&: c) = hdimap f g v :&: c
+
+instance HDitraversable f m a => HDitraversable (f :&: p) m a where
+    hdimapM f (v :&: c) = liftM (:&: c) (hdimapM f v)
+
+{-| This class defines how to distribute an annotation over a sum of
+  signatures. -}
+class DistAnn (s :: (* -> *) -> (* -> *) -> * -> *) p s' | s' -> s, s' -> p where
+    {-| Inject an annotation over a signature. -}
+    injectA :: p -> s a b :-> s' a b
+    {-| Project an annotation from a signature. -}
+    projectA :: s' a b :-> (s a b O.:&: p)
+
+class RemA (s :: (* -> *) -> (* -> *) -> * -> *) s' | s -> s' where
+    {-| Remove annotations from a signature. -}
+    remA :: s a b :-> s' a b
+
+instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where
+    remA (Inl (v :&: _)) = Inl v
+    remA (Inr v) = Inr $ remA v
+
+instance RemA (f :&: p) f where
+    remA (v :&: _) = v
+
+instance DistAnn f p (f :&: p) where
+    injectA c v = v :&: c
+
+    projectA (v :&: p) = v O.:&: p
+
+instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where
+    injectA c (Inl v) = Inl (v :&: c)
+    injectA c (Inr v) = Inr $ injectA c v
+
+    projectA (Inl (v :&: p)) = Inl v O.:&: p
+    projectA (Inr v) = let (v' O.:&: p) = projectA v
+                       in Inr v' O.:&: p
diff --git a/src/Data/Comp/MultiParam/Ordering.hs b/src/Data/Comp/MultiParam/Ordering.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Ordering.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,
+  UndecidableInstances, IncoherentInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Ordering
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines ordering of signatures, which lifts to ordering of
+-- terms and contexts.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.Ordering
+    (
+     POrd(..),
+     OrdHD(..)
+    ) where
+
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Sum
+import Data.Comp.MultiParam.Ops
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.FreshM
+import Data.Comp.MultiParam.Equality
+
+-- |Ordering of parametric values.
+class PEq a => POrd a where
+    pcompare :: a i -> a j -> FreshM Ordering
+
+instance Ord a => POrd (K a) where
+    pcompare (K x) (K y) = return $ compare x y
+
+{-| Signature ordering. An instance @OrdHD f@ gives rise to an instance
+  @Ord (Term f)@. -}
+class EqHD f => OrdHD f where
+    compareHD :: POrd a => f Var a i -> f Var a j -> FreshM Ordering
+
+{-| 'OrdHD' is propagated through sums. -}
+instance (OrdHD f, OrdHD g) => OrdHD (f :+: g) where
+    compareHD (Inl x) (Inl y) = compareHD x y
+    compareHD (Inl _) (Inr _) = return LT
+    compareHD (Inr x) (Inr y) = compareHD x y
+    compareHD (Inr _) (Inl _) = return GT
+
+{-| From an 'OrdHD' difunctor an 'Ord' instance of the corresponding term type
+  can be derived. -}
+instance OrdHD f => OrdHD (Cxt h f) where
+    compareHD (Term e1) (Term e2) = compareHD e1 e2
+    compareHD (Hole h1) (Hole h2) = pcompare h1 h2
+    compareHD (Place p1) (Place p2) = pcompare p1 p2
+    compareHD (Term _) _ = return LT
+    compareHD (Hole _) (Term _) = return GT
+    compareHD (Hole _) (Place _) = return LT
+    compareHD (Place _) _ = return GT
+
+instance POrd Var where
+    pcompare x y = return $ varCompare x y
+
+instance (OrdHD f, POrd a) => POrd (Cxt h f Var a) where
+    pcompare = compareHD
+
+{-| Ordering of terms. -}
+instance (HDifunctor f, OrdHD f) => Ord (Term f i) where
+    compare x y = evalFreshM $ compareHD (coerceCxt x) (coerceCxt y)
diff --git a/src/Data/Comp/MultiParam/Show.hs b/src/Data/Comp/MultiParam/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Show.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances,
+  IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Show
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines showing of signatures, which lifts to showing of terms.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.MultiParam.Show
+    (
+     PShow(..),
+     ShowHD(..)
+    ) where
+
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.Ops
+import Data.Comp.MultiParam.Derive
+import Data.Comp.MultiParam.FreshM
+
+instance Show a => PShow (K a) where
+    pshow = return . show . unK
+
+-- Lift ShowHD to sums
+$(derive [liftSum] [''ShowHD])
+
+instance PShow Var where
+    pshow = return . varShow
+
+{-| From an 'ShowHD' higher-order difunctor an 'ShowHD' instance of the
+  corresponding term type can be derived. -}
+instance (ShowHD f, PShow a) => PShow (Cxt h f Var a) where
+    pshow (Term t) = showHD t
+    pshow (Hole h) = pshow h
+    pshow (Place p) = pshow p
+
+{-| Printing of terms. -}
+instance (HDifunctor f, ShowHD f) => Show (Term f i) where
+    show = evalFreshM . pshow .
+           (coerceCxt :: Term f i -> Trm f Var i)
+
+instance (ShowHD f, PShow (K p)) => ShowHD (f :&: p) where
+    showHD (x :&: p) = do sx <- showHD x
+                          sp <- pshow $ K p
+                          return $ sx ++ " :&: " ++ sp
diff --git a/src/Data/Comp/MultiParam/Sum.hs b/src/Data/Comp/MultiParam/Sum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Sum.hs
@@ -0,0 +1,291 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,
+  FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
+  ScopedTypeVariables, TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Sum
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides the infrastructure to extend signatures.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Sum
+    (
+     (:<:),
+     (:+:),
+
+     -- * Projections for Signatures and Terms
+     proj,
+     proj2,
+     proj3,
+     proj4,
+     proj5,
+     proj6,
+     proj7,
+     proj8,
+     proj9,
+     proj10,
+     project,
+     project2,
+     project3,
+     project4,
+     project5,
+     project6,
+     project7,
+     project8,
+     project9,
+     project10,
+     deepProject,
+     deepProject2,
+     deepProject3,
+     deepProject4,
+     deepProject5,
+     deepProject6,
+     deepProject7,
+     deepProject8,
+     deepProject9,
+     deepProject10,
+
+     -- * Injections for Signatures and Terms
+     inj,
+     inj2,
+     inj3,
+     inj4,
+     inj5,
+     inj6,
+     inj7,
+     inj8,
+     inj9,
+     inj10,
+     inject,
+     inject2,
+     inject3,
+     inject4,
+     inject5,
+     inject6,
+     inject7,
+     inject8,
+     inject9,
+     inject10,
+     deepInject,
+     deepInject2,
+     deepInject3,
+     deepInject4,
+     deepInject5,
+     deepInject6,
+     deepInject7,
+     deepInject8,
+     deepInject9,
+     deepInject10,
+
+     -- * Injections and Projections for Constants
+     injectConst,
+     injectConst2,
+     injectConst3,
+     projectConst,
+     injectCxt,
+     liftCxt
+    ) where
+
+import Prelude hiding (sequence)
+import Control.Monad hiding (sequence)
+import Data.Comp.MultiParam.Term
+import Data.Comp.MultiParam.Algebra
+import Data.Comp.MultiParam.Ops
+import Data.Comp.MultiParam.Derive.Projections
+import Data.Comp.MultiParam.Derive.Injections
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.HDitraversable
+
+$(liftM concat $ mapM projn [2..10])
+
+-- |Project the outermost layer of a term to a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.
+project :: (g :<: f) => NatM Maybe (Cxt h f a b) (g a (Cxt h f a b))
+project (Term t) = proj t
+project (Hole _) = Nothing
+project (Place _) = Nothing
+
+$(liftM concat $ mapM projectn [2..10])
+
+-- | Tries to coerce a term/context to a term/context over a sub-signature. If
+-- the signature @g@ is compound of /n/ atomic signatures, use
+-- @deepProject@/n/ instead.
+deepProject :: (HDitraversable g Maybe Any, g :<: f) => CxtFunM Maybe f g
+{-# INLINE deepProject #-}
+deepProject = appSigFunM' proj
+
+$(liftM concat $ mapM deepProjectn [2..10])
+{-# INLINE deepProject2 #-}
+{-# INLINE deepProject3 #-}
+{-# INLINE deepProject4 #-}
+{-# INLINE deepProject5 #-}
+{-# INLINE deepProject6 #-}
+{-# INLINE deepProject7 #-}
+{-# INLINE deepProject8 #-}
+{-# INLINE deepProject9 #-}
+{-# INLINE deepProject10 #-}
+
+$(liftM concat $ mapM injn [2..10])
+
+-- |Inject a term where the outermost layer is a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.
+inject :: (g :<: f) => g a (Cxt h f a b) :-> Cxt h f a b
+inject = Term . inj
+
+$(liftM concat $ mapM injectn [2..10])
+
+-- |Inject a term over a sub signature to a term over larger signature. If the
+-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/
+-- instead.
+deepInject :: (HDifunctor g, g :<: f) => CxtFun g f
+{-# INLINE deepInject #-}
+deepInject = appSigFun inj
+
+$(liftM concat $ mapM deepInjectn [2..10])
+{-# INLINE deepInject2 #-}
+{-# INLINE deepInject3 #-}
+{-# INLINE deepInject4 #-}
+{-# INLINE deepInject5 #-}
+{-# INLINE deepInject6 #-}
+{-# INLINE deepInject7 #-}
+{-# INLINE deepInject8 #-}
+{-# INLINE deepInject9 #-}
+{-# INLINE deepInject10 #-}
+
+{-{-| A variant of 'proj' for binary sum signatures.  -}
+proj2 :: forall f g1 g2 a b i. (g1 :<: f, g2 :<: f) => f a b i
+      -> Maybe ((g1 :+: g2) a b i)
+proj2 x = case proj x of
+            Just (y :: g1 a b i) -> Just $ inj y
+            _ -> liftM inj (proj x :: Maybe (g2 a b i))
+
+{-| A variant of 'proj' for ternary sum signatures.  -}
+proj3 :: forall f g1 g2 g3 a b i. (g1 :<: f, g2 :<: f, g3 :<: f) => f a b i
+      -> Maybe ((g1 :+: g2 :+: g3) a b i)
+proj3 x = case proj x of
+            Just (y :: g1 a b i) -> Just $ inj y
+            _ -> case proj x of
+                   Just (y :: g2 a b i) -> Just $ inj y
+                   _ -> liftM inj (proj x :: Maybe (g3 a b i))
+
+-- |Project the outermost layer of a term to a sub signature.
+project :: (g :<: f) => NatM Maybe (Cxt h f a b) (g a (Cxt h f a b))
+project (Term t) = proj t
+project (Hole _) = Nothing
+project (Place _) = Nothing
+
+-- |Project the outermost layer of a term to a binary sub signature.
+project2 :: (g1 :<: f, g2 :<: f)
+            => NatM Maybe (Cxt h f a b) ((g1 :+: g2) a (Cxt h f a b))
+project2 (Term t) = proj2 t
+project2 (Hole _) = Nothing
+project2 (Place _) = Nothing
+
+-- |Project the outermost layer of a term to a ternary sub signature.
+project3 :: (g1 :<: f, g2 :<: f, g3 :<: f)
+            => NatM Maybe (Cxt h f a b) ((g1 :+: g2 :+: g3) a (Cxt h f a b))
+project3 (Term t) = proj3 t
+project3 (Hole _) = Nothing
+project3 (Place _) = Nothing
+
+-- | Tries to coerce a term/context to a term/context over a
+-- sub-signature.
+deepProject :: (HDitraversable g Maybe Any, g :<: f)
+             => CxtFunM Maybe f g
+deepProject = appSigFunM' proj
+
+-- | This is a variant of 'deepProject' that can be used if the target
+-- signature cannot be derived as being a sub-signature of the source
+-- signature directly but its decomposition into two summands can.
+deepProject2 :: (HDitraversable (g1 :+: g2) Maybe Any, g1 :<: f, g2 :<: f)
+              => CxtFunM Maybe f (g1 :+: g2)
+deepProject2 = appSigFunM' proj2
+
+-- | This is a variant of 'deepProject' that can be used if the target
+-- signature cannot be derived as being a sub-signature of the source
+-- signature directly but its decomposition into three summands can.
+deepProject3 ::(HDitraversable (g1 :+: g2 :+: g3) Maybe Any, g1 :<: f, g2 :<: f, g3 :<: f)
+                 => CxtFunM Maybe f (g1 :+: g2 :+: g3)
+deepProject3 = appSigFunM' proj3
+
+{-| A variant of 'inj' for binary sum signatures.  -}
+inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a b :-> g a b
+inj2 (Inl x) = inj x
+inj2 (Inr y) = inj y
+
+{-| A variant of 'inj' for ternary sum signatures.  -}
+inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a b :-> g a b
+inj3 (Inl x) = inj x
+inj3 (Inr y) = inj2 y
+
+-- |Inject a term where the outermost layer is a sub signature.
+inject :: (g :<: f) => g a (Cxt h f a b) :-> Cxt h f a b
+inject = Term . inj
+
+-- |Inject a term where the outermost layer is a binary sub signature.
+inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a (Cxt h g a b) :-> Cxt h g a b
+inject2 = Term . inj2
+
+-- |Inject a term where the outermost layer is a ternary sub signature.
+inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a (Cxt h g a b)
+        :-> Cxt h g a b
+inject3 = Term . inj3
+
+-- |Inject a term over a sub signature to a term over larger signature.
+deepInject :: (HDifunctor g, g :<: f) => CxtFun g f
+deepInject = appSigFun inj
+
+-- |Inject a term over a binary sub signature to a term over larger signature.
+deepInject2 :: (HDifunctor (f1 :+: f2), f1 :<: g, f2 :<: g)  => CxtFun (f1 :+: f2) g
+deepInject2 = appSigFun inj2
+
+-- |Inject a term over a ternary signature to a term over larger signature.
+deepInject3 :: (HDifunctor (f1 :+: f2 :+: f3), f1 :<: g, f2 :<: g, f3 :<: g)
+               => CxtFun (f1 :+: f2 :+: f3) g
+deepInject3 =  appSigFun inj3-}
+
+injectConst :: (HDifunctor g, g :<: f) => Const g :-> Cxt h f Any a
+injectConst = inject . hfmap (const undefined)
+
+injectConst2 :: (HDifunctor f1, HDifunctor f2, HDifunctor g, f1 :<: g, f2 :<: g)
+                => Const (f1 :+: f2) :-> Cxt h g Any a
+injectConst2 = inject2 . hfmap (const undefined)
+
+injectConst3 :: (HDifunctor f1, HDifunctor f2, HDifunctor f3, HDifunctor g,
+                 f1 :<: g, f2 :<: g, f3 :<: g)
+                => Const (f1 :+: f2 :+: f3) :-> Cxt h g Any a
+injectConst3 = inject3 . hfmap (const undefined)
+
+projectConst :: (HDifunctor g, g :<: f) => NatM Maybe (Cxt h f Any a) (Const g)
+projectConst = fmap (hfmap (const (K ()))) . project
+
+{-| This function injects a whole context into another context. -}
+injectCxt :: (HDifunctor g, g :<: f) => Cxt h g a (Cxt h f a b) :-> Cxt h f a b
+injectCxt (Term t) = inject $ hfmap injectCxt t
+injectCxt (Hole x) = x
+injectCxt (Place p) = Place p
+
+{-| This function lifts the given functor to a context. -}
+liftCxt :: (HDifunctor f, g :<: f) => g a b :-> Cxt Hole f a b
+liftCxt g = simpCxt $ inj g
+
+instance (Show (f a b i), Show (g a b i)) => Show ((f :+: g) a b i) where
+    show (Inl v) = show v
+    show (Inr v) = show v
+
+instance (Ord (f a b i), Ord (g a b i)) => Ord ((f :+: g) a b i) where
+    compare (Inl _) (Inr _) = LT
+    compare (Inr _) (Inl _) = GT
+    compare (Inl x) (Inl y) = compare x y
+    compare (Inr x) (Inr y) = compare x y
+
+instance (Eq (f a b i), Eq (g a b i)) => Eq ((f :+: g) a b i) where
+    (Inl x) == (Inl y) = x == y
+    (Inr x) == (Inr y) = x == y                   
+    _ == _ = False
diff --git a/src/Data/Comp/MultiParam/Term.hs b/src/Data/Comp/MultiParam/Term.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/MultiParam/Term.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE GADTs, KindSignatures, RankNTypes, MultiParamTypeClasses,
+  TypeOperators, ScopedTypeVariables, EmptyDataDecls #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.MultiParam.Term
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the central notion of /generalised parametrised terms/
+-- and their generalisation to generalised parametrised contexts.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.MultiParam.Term
+    (
+     Cxt(..),
+     Hole,
+     NoHole,
+     Any,
+     Term,
+     Trm,
+     Context,
+     Const,
+     simpCxt,
+     coerceCxt,
+     toCxt,
+     constTerm,
+     hfmapCxt,
+     hdimapMCxt
+    ) where
+
+import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)
+import Data.Comp.MultiParam.Any
+import Data.Comp.MultiParam.HDifunctor
+import Data.Comp.MultiParam.HDitraversable
+import Control.Monad 
+import Unsafe.Coerce
+
+{-| This data type represents contexts over a signature. Contexts are terms
+  containing zero or more holes, and zero or more parameters. The first
+  parameter is a phantom type indicating whether the context has holes. The
+  second paramater is the signature of the context, in the form of a
+  "Data.Comp.MultiParam.HDifunctor". The third parameter is the type of
+  parameters, the fourth parameter is the type of holes, and the fifth
+  parameter is the GADT type. -}
+data Cxt :: * -> ((* -> *) -> (* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> * where
+            Term :: f a (Cxt h f a b) i -> Cxt h f a b i
+            Hole :: b i -> Cxt Hole f a b i
+            Place :: a i -> Cxt h f a b i
+
+{-| Phantom type used to define 'Context'. -}
+data Hole
+
+{-| Phantom type used to define 'Term'. -}
+data NoHole
+
+{-| A context may contain holes, but must be parametric in the bound
+  parameters. Parametricity is \"emulated\" using the empty functor @Any@,
+  e.g. a function of type @Any :-> T[Any]@ is equivalent with
+  @forall b. b :-> T[b]@, but the former avoids the impredicative typing
+  extension, and works also in the cases where the codomain type is not a type
+  constructor, e.g. @Any i -> (Any i,Any i)@. -}
+type Context = Cxt Hole
+
+
+type Trm f a = Cxt NoHole f a (K ())
+
+{-| A term is a context with no holes, where all occurrences of the
+  contravariant parameter is fully parametric. Parametricity is \"emulated\"
+  using the empty functor @Any@, e.g. a function of type @Any :-> T[Any]@ is
+  equivalent with @forall b. b :-> T[b]@, but the former avoids the
+  impredicative typing extension, and works also in the cases where the
+  codomain type is not a type constructor, e.g. @Any i -> (Any i,Any i)@. -}
+type Term f = Trm f Any
+
+{-| Convert a difunctorial value into a context. -}
+simpCxt :: HDifunctor f => f a b :-> Cxt Hole f a b
+{-# INLINE simpCxt #-}
+simpCxt = Term . hfmap Hole
+
+{-| Cast a \"pseudo-parametric\" context over a signature to a parametric
+  context over the same signature. The usage of 'unsafeCoerce' is safe, because
+  the empty functor 'Any' witnesses that all uses of the contravariant argument
+  are parametric. -}
+coerceCxt :: Cxt h f Any b i -> forall a. Cxt h f a b i
+coerceCxt = unsafeCoerce
+
+toCxt :: HDifunctor f => Trm f a :-> Cxt h f a b
+{-# INLINE toCxt #-}
+toCxt = unsafeCoerce
+
+{-|  -}
+type Const f i = f Any (K ()) i
+
+{-| This function converts a constant to a term. This assumes that the
+  argument is indeed a constant, i.e. does not have a value for the
+  argument type of the higher-order difunctor @f@. -}
+constTerm :: HDifunctor f => Const f :-> Term f
+constTerm = Term . hfmap (const undefined)
+
+-- | This is an instance of 'hfmap' for 'Cxt'.
+hfmapCxt :: forall h f a b b'. HDifunctor f
+         => (b :-> b') -> Cxt h f a b :-> Cxt h f a b'
+hfmapCxt f = run
+    where run :: Cxt h f a b :-> Cxt h f a b'
+          run (Term t) = Term $ hfmap run t
+          run (Place a) = Place a
+          run (Hole b)  = Hole $ f b
+
+-- | This is an instance of 'hdimapM' for 'Cxt'.
+hdimapMCxt :: forall h f a b b' m . HDitraversable f m a
+          => (NatM m b b') -> NatM m (Cxt h f a b) (Cxt h f a b')
+hdimapMCxt f = run
+    where run :: NatM m (Cxt h f a b) (Cxt h f a b')
+          run (Term t)  = liftM Term $ hdimapM run t
+          run (Place a) = return $ Place a
+          run (Hole b)  = liftM Hole (f b)
diff --git a/src/Data/Comp/Ops.hs b/src/Data/Comp/Ops.hs
--- a/src/Data/Comp/Ops.hs
+++ b/src/Data/Comp/Ops.hs
@@ -104,8 +104,7 @@
 
 infixr 7 :&:
 
-{-| This data type adds a constant product to a signature.  -}
-
+{-| This data type adds a constant product (annotation) to a signature. -}
 data (f :&: a) e = f e :&: a
 
 
@@ -126,42 +125,41 @@
     mapM f (v :&: c) = liftM (:&: c) (mapM f v)
     sequence (v :&: c) = liftM (:&: c) (sequence v)
 
-{-| This class defines how to distribute a product over a sum of
+{-| This class defines how to distribute an annotation over a sum of
 signatures. -}
-
-class DistProd s p s' | s' -> s, s' -> p where
-    {-| Inject a product value over a signature. -}
-    injectP :: p -> s a -> s' a
-    {-| Project a product value from a signature. -}
-    projectP :: s' a -> (s a, p)
+class DistAnn s p s' | s' -> s, s' -> p where
+    {-| Inject an annotation over a signature. -}
+    injectA :: p -> s a -> s' a
+    {-| Project an annotation from a signature. -}
+    projectA :: s' a -> (s a, p)
 
 
-class RemoveP s s' | s -> s'  where
-    {-| Remove products from a signature. -}
-    removeP :: s a -> s' a
+class RemA s s' | s -> s'  where
+    {-| Remove annotations from a signature. -}
+    remA :: s a -> s' a
 
-instance (RemoveP s s') => RemoveP (f :&: p :+: s) (f :+: s') where
-    removeP (Inl (v :&: _)) = Inl v
-    removeP (Inr v) = Inr $ removeP v
+instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where
+    remA (Inl (v :&: _)) = Inl v
+    remA (Inr v) = Inr $ remA v
 
 
-instance RemoveP (f :&: p) f where
-    removeP (v :&: _) = v
+instance RemA (f :&: p) f where
+    remA (v :&: _) = v
 
 
-instance DistProd f p (f :&: p) where
+instance DistAnn f p (f :&: p) where
 
-    injectP c v = v :&: c
+    injectA c v = v :&: c
 
-    projectP (v :&: p) = (v,p)
+    projectA (v :&: p) = (v,p)
 
 
-instance (DistProd s p s') => DistProd (f :+: s) p ((f :&: p) :+: s') where
+instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where
 
 
-    injectP c (Inl v) = Inl (v :&: c)
-    injectP c (Inr v) = Inr $ injectP c v
+    injectA c (Inl v) = Inl (v :&: c)
+    injectA c (Inr v) = Inr $ injectA c v
 
-    projectP (Inl (v :&: p)) = (Inl v,p)
-    projectP (Inr v) = let (v',p) = projectP v
+    projectA (Inl (v :&: p)) = (Inl v,p)
+    projectA (Inr v) = let (v',p) = projectA v
                        in  (Inr v',p)
diff --git a/src/Data/Comp/Ordering.hs b/src/Data/Comp/Ordering.hs
--- a/src/Data/Comp/Ordering.hs
+++ b/src/Data/Comp/Ordering.hs
@@ -19,6 +19,7 @@
 
 import Data.Comp.Term
 import Data.Comp.Sum
+import Data.Comp.Ops
 import Data.Comp.Equality ()
 import Data.Comp.Derive
 import Data.Comp.Derive.Utils
@@ -46,11 +47,10 @@
 {-|
   'OrdF' is propagated through sums.
 -}
-
 instance (OrdF f, OrdF g) => OrdF (f :+: g) where
     compareF (Inl _) (Inr _) = LT
     compareF (Inr _) (Inl _) = GT
     compareF (Inl x) (Inl y) = compareF x y
     compareF (Inr x) (Inr y) = compareF x y
 
-$(derive [instanceOrdF] $ [''Maybe, ''[]] ++ tupleTypes 2 10)
+$(derive [makeOrdF] $ [''Maybe, ''[]] ++ tupleTypes 2 10)
diff --git a/src/Data/Comp/Param.hs b/src/Data/Comp/Param.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param.hs
@@ -0,0 +1,32 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the infrastructure necessary to use
+-- /Parametric Compositional Data Types/. Parametric Compositional Data Types 
+-- is an extension of Compositional Data Types with parametric
+-- higher-order abstract syntax (PHOAS) for usage with binders. Examples of
+-- usage are bundled with the package in the library
+-- @examples\/Examples\/Param@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param (
+    module Data.Comp.Param.Term
+  , module Data.Comp.Param.Algebra
+  , module Data.Comp.Param.Difunctor
+  , module Data.Comp.Param.Sum
+  , module Data.Comp.Param.Annotation
+  , module Data.Comp.Param.Equality
+    ) where
+
+import Data.Comp.Param.Term
+import Data.Comp.Param.Algebra
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Sum
+import Data.Comp.Param.Annotation
+import Data.Comp.Param.Equality
diff --git a/src/Data/Comp/Param/Algebra.hs b/src/Data/Comp/Param/Algebra.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Algebra.hs
@@ -0,0 +1,930 @@
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators,
+  FlexibleContexts, CPP #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Algebra
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the notion of algebras and catamorphisms, and their
+-- generalizations to e.g. monadic versions and other (co)recursion schemes.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Algebra (
+      -- * Algebras & Catamorphisms
+      Alg,
+      free,
+      cata,
+      cata',
+      appCxt,
+      
+      -- * Monadic Algebras & Catamorphisms
+      AlgM,
+      algM,
+      freeM,
+      cataM,
+      cataM',
+
+      -- * Term Homomorphisms
+      CxtFun,
+      SigFun,
+      TermHom,
+      appTermHom,
+      appTermHom',
+      compTermHom,
+      appSigFun,
+      appSigFun',
+      compSigFun,
+      compTermHomSigFun,
+      compSigFunTermHom,
+      termHom,
+      compAlg,
+      compAlgSigFun,
+
+      -- * Monadic Term Homomorphisms
+      CxtFunM,
+      SigFunM,
+      TermHomM,
+      SigFunMD,
+      TermHomMD,
+      sigFunM,
+      appTermHomM,
+      appTermHomM',
+      termHomM,
+      termHomMD,
+      appSigFunM,
+      appSigFunM',
+      appSigFunMD,
+      compTermHomM,
+      compSigFunM,
+      compSigFunTermHomM,
+      compAlgSigFunM,
+      compAlgSigFunM',
+      compAlgM,
+      compAlgM',
+
+      -- * Coalgebras & Anamorphisms
+      Coalg,
+      ana,
+      CoalgM,
+      anaM,
+
+      -- * R-Algebras & Paramorphisms
+      RAlg,
+      para,
+      RAlgM,
+      paraM,
+
+      -- * R-Coalgebras & Apomorphisms
+      RCoalg,
+      apo,
+      RCoalgM,
+      apoM,
+
+      -- * CV-Algebras & Histomorphisms
+      CVAlg,
+      histo,
+      CVAlgM,
+      histoM,
+
+      -- * CV-Coalgebras & Futumorphisms
+      CVCoalg,
+      futu,
+      CVCoalg',
+      futu',
+      CVCoalgM,
+      futuM
+    ) where
+
+import Prelude hiding (sequence, mapM)
+import Control.Monad hiding (sequence, mapM)
+import Data.Comp.Param.Term
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Ditraversable
+
+import Unsafe.Coerce (unsafeCoerce)
+
+{-| This type represents an algebra over a difunctor @f@ and carrier @a@. -}
+type Alg f a = f a a -> a
+
+{-| Construct a catamorphism for contexts over @f@ with holes of type @b@, from
+  the given algebra. -}
+free :: forall h f a b. Difunctor f
+        => Alg f a -> (b -> a) -> Cxt h f a b -> a
+free f g = run
+    where run :: Cxt h f a b -> a
+          run (Term t) = f (fmap run t)
+          run (Hole x) = g x
+          run (Place p) = p
+
+{-| Construct a catamorphism from the given algebra. -}
+cata :: forall f a. Difunctor f => Alg f a -> Term f -> a 
+{-# NOINLINE [1] cata #-}
+cata f = run . coerceCxt
+    where run :: Trm f a -> a
+          run (Term t) = f (fmap run t)
+          run (Place x) = x
+
+{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where
+  the holes have the type of the algebra carrier. -}
+cata' :: Difunctor f => Alg f a -> Cxt h f a a -> a
+{-# INLINE cata' #-}
+cata' f = free f id
+
+{-| This function applies a whole context into another context. -}
+appCxt :: Difunctor f => Context f a (Cxt h f a b) -> Cxt h f a b
+appCxt (Term t) = Term (fmap appCxt t)
+appCxt (Hole x) = x
+appCxt (Place p) = Place p
+
+{-| This type represents a monadic algebra. It is similar to 'Alg' but
+  the return type is monadic. -}
+type AlgM m f a = f a a -> m a
+
+{-| Convert a monadic algebra into an ordinary algebra with a monadic
+  carrier. -}
+algM :: (Ditraversable f m a, Monad m) => AlgM m f a -> Alg f (m a)
+algM f x = disequence (dimap return id x) >>= f
+
+{-| Construct a monadic catamorphism for contexts over @f@ with holes of type
+  @b@, from the given monadic algebra. -}
+freeM :: forall m h f a b. (Ditraversable f m a, Monad m)
+         => AlgM m f a -> (b -> m a) -> Cxt h f a b -> m a
+freeM f g = run
+    where run :: Cxt h f a b -> m a
+          run (Term t) = f =<< dimapM run t
+          run (Hole x) = g x
+          run (Place p) = return p
+
+{-| Construct a monadic catamorphism from the given monadic algebra. -}
+cataM :: forall m f a. (Ditraversable f m a, Monad m)
+         => AlgM m f a -> Term f -> m a
+{-# NOINLINE [1] cataM #-}
+cataM algm = run . coerceCxt
+    where run :: Trm f a  -> m a
+          run (Term t) = algm =<< dimapM run t
+          run (Place x) = return x
+
+{-| A generalisation of 'cataM' from terms over @f@ to contexts over @f@, where
+  the holes have the type of the monadic algebra carrier. -}
+cataM' :: forall m h f a. (Ditraversable f m a, Monad m)
+          => AlgM m f a -> Cxt h f a (m a) -> m a
+{-# NOINLINE [1] cataM' #-}
+cataM' f = freeM f id
+
+{-| This type represents a context function. -}
+type CxtFun f g = forall h a b. Cxt h f a b -> Cxt h g a b
+
+
+{-| This type represents a signature function. -}
+type SigFun f g = forall a b. f a b -> g a b
+
+{-| This type represents a term homomorphism. -}
+type TermHom f g = SigFun f (Context g)
+
+{-| Apply a term homomorphism recursively to a term/context. -}
+appTermHom :: forall f g. (Difunctor f, Difunctor g)
+              => TermHom f g -> CxtFun f g
+{-# NOINLINE [1] appTermHom #-}
+appTermHom f = run where
+    run :: CxtFun f g
+    run (Term t) = appCxt (f (fmap run t))
+    run (Hole x) = Hole x
+    run (Place p) = Place p
+
+{-| Apply a term homomorphism recursively to a term/context. -}
+appTermHom' :: forall f g. (Difunctor g)
+              => TermHom f g -> CxtFun f g
+{-# NOINLINE [1] appTermHom' #-}
+appTermHom' f = run where
+    run :: CxtFun f g
+    run (Term t) = appCxt (fmapCxt run (f t))
+    run (Hole x) = Hole x
+    run (Place p) = Place p
+
+{-| Compose two term homomorphisms. -}
+compTermHom :: (Difunctor g, Difunctor h)
+               => TermHom g h -> TermHom f g -> TermHom f h
+compTermHom f g = appTermHom f . g
+
+
+{-| Compose an algebra with a term homomorphism to get a new algebra. -}
+compAlg :: (Difunctor f, Difunctor g) => Alg g a -> TermHom f g -> Alg f a
+compAlg alg talg = cata' alg . talg
+
+compAlgSigFun  :: Alg g a -> SigFun f g -> Alg f a
+compAlgSigFun alg sig = alg . sig
+
+
+{-| This function applies a signature function to the given context. -}
+appSigFun :: forall f g. (Difunctor f) => SigFun f g -> CxtFun f g
+{-# NOINLINE [1] appSigFun #-}
+appSigFun f = run
+    where run (Term t) = Term $ f $ fmap run t
+          run (Place x) = Place x
+          run (Hole x) = Hole x
+-- implementation via term homomorphisms
+--  appSigFun f = appTermHom $ termHom f
+
+
+-- | This function applies a signature function to the given
+-- context. This is a top-bottom variant of 'appSigFun'.
+appSigFun' :: forall f g. (Difunctor g) => SigFun f g -> CxtFun f g
+{-# NOINLINE [1] appSigFun' #-}
+appSigFun' f = run
+    where run (Term t) = Term $ fmap run $ f t
+          run (Place x) = Place x
+          run (Hole x) = Hole x
+
+{-| This function composes two signature functions. -}
+compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
+compSigFun f g = f . g
+
+{-| This function composes a term homomorphism and a signature function. -}
+compTermHomSigFun :: TermHom g h -> SigFun f g -> TermHom f h
+compTermHomSigFun f g = f . g
+
+{-| This function composes a term homomorphism and a signature function. -}
+compSigFunTermHom :: (Difunctor g) => SigFun g h -> TermHom f g -> TermHom f h
+compSigFunTermHom f g = appSigFun f . g
+
+
+{-| Lifts the given signature function to the canonical term homomorphism. -}
+termHom :: Difunctor g => SigFun f g -> TermHom f g
+termHom f = simpCxt . f
+
+{-| This type represents a monadic signature function. -}
+type SigFunM m f g = forall a b. f a b -> m (g a b)
+
+{-| This type represents a monadic context function. -}
+type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g)
+
+{-| This type represents a monadic context function. -}
+type CxtFunM' m f g = forall h b. Cxt h f Any b -> m (Cxt h g Any b)
+
+coerceCxtFunM :: CxtFunM' m f g -> CxtFunM m f g
+coerceCxtFunM = unsafeCoerce
+
+{-| This type represents a monadic signature function. It is similar to
+  'SigFunMD but has monadic values also in the domain. -}
+type SigFunMD m f g = forall a b. f a (m b) -> m (g a b)
+
+{-| This type represents a monadic term homomorphism. -}
+type TermHomM m f g = SigFunM m f (Context g)
+
+{-| This type represents a monadic term homomorphism. It is similar to
+  'TermHomMD but has monadic values also in the domain. -}
+type TermHomMD m f g = SigFunMD m f (Context g)
+
+{-| Lift the given signature function to a monadic signature function. Note that
+  term homomorphisms are instances of signature functions. Hence this function
+  also applies to term homomorphisms. -}
+sigFunM :: Monad m => SigFun f g -> SigFunM m f g
+sigFunM f = return . f
+
+
+
+{-| Lift the given signature function to a monadic term homomorphism. -}
+termHomM :: (Difunctor g, Monad m) => SigFunM m f g -> TermHomM m f g
+termHomM f = liftM simpCxt . f
+
+-- | Apply a monadic term homomorphism recursively to a
+-- term/context. The monad is sequenced bottom-up.
+appTermHomM :: forall f g m. (Ditraversable f m Any, Difunctor g)
+               => TermHomM m f g -> CxtFunM m f g
+{-# NOINLINE [1] appTermHomM #-}
+appTermHomM f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM appCxt . f =<< dimapM run t
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+
+-- | Apply a monadic term homomorphism recursively to a
+-- term/context. The monad is sequence top-down.
+appTermHomM' :: forall f g m. (Ditraversable g m Any)
+         => TermHomM m f g ->  CxtFunM m f g
+appTermHomM' f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t)  = liftM appCxt . dimapMCxt run =<< f t
+          run (Place p) = return (Place p)
+          run (Hole x) = return (Hole x)
+            
+
+{-| This function constructs the unique monadic homomorphism from the
+  initial term algebra to the given term algebra. -}
+termHomMD :: forall f g m. (Difunctor f, Difunctor g, Monad m)
+             => TermHomMD m f g -> CxtFunM m f g
+termHomMD f = run 
+    where run :: CxtFunM m f g
+          run (Term t) = liftM appCxt (f (fmap run t))
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+{-| This function applies a monadic signature function to the given context. -}
+appSigFunM :: forall m f g . (Ditraversable f m Any)
+              => SigFunM m f g -> CxtFunM m f g
+appSigFunM f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM Term . f =<< dimapM run t
+          run (Place x) = return $ Place x
+          run (Hole x) = return $ Hole x
+-- implementation via term homomorphisms
+--  appSigFunM f = appTermHomM $ termHom' f
+
+-- | This function applies a monadic signature function to the given
+-- context. This is a 'top-down variant of 'appSigFunM'.
+appSigFunM' :: forall m f g . (Ditraversable g m Any)
+              => SigFunM m f g -> CxtFunM m f g
+appSigFunM' f = coerceCxtFunM run
+    where run :: CxtFunM' m f g
+          run (Term t) = liftM Term . dimapM run =<< f t
+          run (Place x) = return $ Place x
+          run (Hole x) = return $ Hole x
+
+
+{-| This function applies a signature function to the given context. -}
+appSigFunMD :: forall f g m. (Ditraversable f m Any, Difunctor g, Monad m)
+               => SigFunMD m f g -> CxtFunM m f g
+appSigFunMD f = run 
+    where run :: CxtFunM m f g
+          run (Term t) = liftM Term (f (fmap run t))
+          run (Hole x) = return (Hole x)
+          run (Place p) = return (Place p)
+
+{-| Compose two monadic term homomorphisms. -}
+compTermHomM :: (Ditraversable g m Any, Difunctor h, Monad m)
+                => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM f g = appTermHomM f <=< g
+
+{-| Compose two monadic term homomorphisms. -}
+compTermHomM' :: (Ditraversable h m Any, Monad m)
+                => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM' f g = appTermHomM' f <=< g
+
+{-| Compose two monadic term homomorphisms. -}
+compTermHomM_ :: (Difunctor h, Difunctor g, Monad m)
+                => TermHom g h -> TermHomM m f g -> TermHomM m f h
+compTermHomM_ f g = liftM (appTermHom f) . g
+
+
+{-| Compose two monadic term homomorphisms. -}
+compTermHomSigFunM :: (Monad m) => TermHomM m g h -> SigFunM m f g -> TermHomM m f h
+compTermHomSigFunM f g = f <=< g
+
+{-| Compose two monadic term homomorphisms. -}
+compSigFunTermHomM :: (Ditraversable g m Any) => SigFunM m g h -> TermHomM m f g -> TermHomM m f h
+compSigFunTermHomM f g = appSigFunM f <=< g
+
+{-| Compose two monadic term homomorphisms. -}
+compSigFunTermHomM' :: (Ditraversable h m Any) => SigFunM m g h -> TermHomM m f g -> TermHomM m f h
+compSigFunTermHomM' f g = appSigFunM' f <=< g
+
+{-| Compose a monadic algebra with a monadic term homomorphism to get a new
+  monadic algebra. -}
+compAlgM :: (Ditraversable g m a, Monad m)
+            => AlgM m g a -> TermHomM m f g -> AlgM m f a
+compAlgM alg talg = freeM alg return <=< talg
+
+
+{-| Compose a monadic algebra with a term homomorphism to get a new monadic
+  algebra. -}
+compAlgM' :: (Ditraversable g m a, Monad m) => AlgM m g a
+          -> TermHom f g -> AlgM m f a
+compAlgM' alg talg = freeM alg return . talg
+
+{-| Compose a monadic algebra with a monadic signature function to get a new
+  monadic algebra. -}
+compAlgSigFunM :: (Monad m)
+            => AlgM m g a -> SigFunM m f g -> AlgM m f a
+compAlgSigFunM alg talg = alg <=< talg
+
+
+{-| Compose a monadic algebra with a signature function to get a new monadic
+  algebra. -}
+compAlgSigFunM' :: AlgM m g a -> SigFun f g -> AlgM m f a
+compAlgSigFunM' alg talg = alg . talg
+
+{-| This function composes two monadic signature functions. -}
+compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
+compSigFunM f g = f <=< g
+
+
+----------------
+-- Coalgebras --
+----------------
+
+{-| This type represents a coalgebra over a difunctor @f@ and carrier @a@. The
+  list of @(a,b)@s represent the parameters that may occur in the constructed
+  value. The first component represents the seed of the parameter,
+  and the second component is the (polymorphic) parameter itself. If @f@ is
+  itself a binder, then the parameters bound by @f@ can be passed to the
+  covariant argument, thereby making them available to sub terms. -}
+type Coalg f a = forall b. a -> [(a,b)] -> Either b (f b (a,[(a,b)]))
+
+{-| Construct an anamorphism from the given coalgebra. -}
+ana :: forall a f. Difunctor f => Coalg f a -> a -> Term f
+ana f x = run (x,[])
+    where run (a,bs) = case f a bs of
+                         Left p -> Place p
+                         Right t -> Term $ fmap run t
+
+{-| This type represents a monadic coalgebra over a difunctor @f@ and carrier
+  @a@. -}
+type CoalgM m f a = forall b. a -> [(a,b)] -> m (Either b (f b (a,[(a,b)])))
+
+{-| Construct a monadic anamorphism from the given monadic coalgebra. -}
+anaM :: forall a m f. (Ditraversable f m Any, Monad m)
+     => CoalgM m f a -> a -> m (Term f)
+anaM f x = run (x,[])
+    where run (a,bs) = do c <- f a bs
+                          case c of
+                            Left p -> return $ Place p
+                            Right t -> liftM Term $ dimapM run t
+
+
+--------------------------------
+-- R-Algebras & Paramorphisms --
+--------------------------------
+
+{-| This type represents an r-algebra over a difunctor @f@ and carrier @a@. -}
+type RAlg f a = f a (Trm f a, a) -> a
+
+{-| Construct a paramorphism from the given r-algebra. -}
+para :: forall f a. Difunctor f => RAlg f a -> Term f -> a
+para f = run . coerceCxt
+    where run :: Trm f a -> a
+          run (Term t) = f $ fmap (\x -> (x, run x)) t
+          run (Place x) = x
+
+{-| This type represents a monadic r-algebra over a difunctor @f@ and carrier
+  @a@. -}
+type RAlgM m f a = f a (Trm f a, a) -> m a
+{-| Construct a monadic paramorphism from the given monadic r-algebra. -}
+paraM :: forall m f a. (Ditraversable f m a, Monad m)
+         => RAlgM m f a -> Term f -> m a
+paraM f = run . coerceCxt
+    where run :: Trm f a -> m a
+          run (Term t) = f =<< dimapM (\x -> run x >>= \y -> return (x, y)) t
+          run (Place x) = return x
+
+
+--------------------------------
+-- R-Coalgebras & Apomorphisms --
+--------------------------------
+
+{-| This type represents an r-coalgebra over a difunctor @f@ and carrier @a@. -}
+type RCoalg f a = forall b. a -> [(a,b)] -> Either b (f b (Either (Trm f b) (a,[(a,b)])))
+
+{-| Construct an apomorphism from the given r-coalgebra. -}
+apo :: forall a f. (Difunctor f) => RCoalg f a -> a -> Term f
+apo coa x = run (x,[])
+    where run :: (a,[(a,b)]) -> Trm f b
+          run (a,bs) = case coa a bs of
+                         Left x -> Place x
+                         Right t -> Term $ fmap run' t
+          run' :: Either (Trm f b) (a,[(a,b)]) -> Trm f b
+          run' (Left t) = t
+          run' (Right x) = run x
+
+
+
+{-| This type represents a monadic r-coalgebra over a functor @f@ and carrier
+  @a@. -}
+type RCoalgM m f a = forall b. a -> [(a,b)] -> m (Either b (f b (Either (Trm f b) (a,[(a,b)]))))
+
+{-| Construct a monadic apomorphism from the given monadic r-coalgebra. -}
+apoM :: forall f m a. (Ditraversable f m Any, Monad m) =>
+        RCoalgM m f a -> a -> m (Term f)
+apoM coa x = run (x,[]) 
+    where run :: (a,[(a,Any)]) -> m (Term f)
+          run (a,bs) = do
+            res <- coa a bs
+            case res of
+              Left x -> return $ Place x
+              Right t -> liftM Term $ dimapM run' t
+          run' :: Either (Term f) (a,[(a,Any)]) -> m (Term f)
+          run' (Left t) = return t
+          run' (Right x) = run x
+
+
+----------------------------------
+-- CV-Algebras & Histomorphisms --
+----------------------------------
+
+{-| This type represents a cv-algebra over a difunctor @f@ and carrier @a@. -}
+type CVAlg f a f' = f a (Trm f' a) -> a
+
+-- | This function applies 'projectA' at the tip of the term.
+projectTip  :: DistAnn f a f' => Trm f' a -> a
+projectTip (Term v) = snd $ projectA v
+projectTip (Place p) = p
+
+{-| Construct a histomorphism from the given cv-algebra. -}
+histo :: forall f f' a. (Difunctor f, DistAnn f a f')
+         => CVAlg f a f' -> Term f -> a
+histo alg = projectTip . cata run
+    where run :: Alg f (Trm f' a)
+          run v = Term $ injectA (alg v') v'
+              where v' = dimap Place id v
+
+{-| This type represents a monadic cv-algebra over a functor @f@ and carrier
+  @a@. -}
+type CVAlgM m f a f' = f a (Trm f' a) -> m a
+
+{-| Construct a monadic histomorphism from the given monadic cv-algebra. -}
+histoM :: forall f f' m a. (Ditraversable f m a, Monad m, DistAnn f a f')
+          => CVAlgM m f a f' -> Term f -> m a
+histoM alg = liftM projectTip . run . coerceCxt
+    where run (Term t) = do t' <- dimapM run t
+                            r <- alg t'
+                            return $ Term $ injectA r t'
+          run (Place p) = return $ Place p
+
+
+-----------------------------------
+-- CV-Coalgebras & Futumorphisms --
+-----------------------------------
+
+{-| This type represents a cv-coalgebra over a difunctor @f@ and carrier @a@.
+  The list of @(a,b)@s represent the parameters that may occur in the
+  constructed value. The first component represents the seed of the parameter,
+  and the second component is the (polymorphic) parameter itself. If @f@ is
+  itself a binder, then the parameters bound by @f@ can be passed to the
+  covariant argument, thereby making them available to sub terms. -}
+type CVCoalg f a = forall b. a -> [(a,b)]
+                 -> Either b (f b (Context f b (a,[(a,b)])))
+
+{-| Construct a futumorphism from the given cv-coalgebra. -}
+futu :: forall f a. Difunctor f => CVCoalg f a -> a -> Term f
+futu coa x = run (x,[])
+    where run (a,bs) = case coa a bs of
+                         Left p -> Place p
+                         Right t -> Term $ fmap run' t
+          run' (Term t) = Term $ fmap run' t
+          run' (Hole x) = run x
+          run' (Place p) = Place p
+
+{-| This type represents a monadic cv-coalgebra over a difunctor @f@ and carrier
+  @a@. -}
+type CVCoalgM m f a = forall b. a -> [(a,b)]
+                    -> m (Either b (f b (Context f b (a,[(a,b)]))))
+
+{-| Construct a monadic futumorphism from the given monadic cv-coalgebra. -}
+futuM :: forall f a m. (Ditraversable f m Any, Monad m) =>
+         CVCoalgM m f a -> a -> m (Term f)
+futuM coa x = run (x,[])
+    where run (a,bs) = do c <- coa a bs
+                          case c of 
+                            Left p -> return $ Place p
+                            Right t -> liftM Term $ dimapM run' t
+          run' (Term t) = liftM Term $ dimapM run' t
+          run' (Hole x) = run x
+          run' (Place p) = return $ Place p
+
+{-| This type represents a generalised cv-coalgebra over a difunctor @f@ and
+  carrier @a@. -}
+type CVCoalg' f a = forall b. a -> [(a,b)] -> Context f b (a,[(a,b)])
+
+{-| Construct a futumorphism from the given generalised cv-coalgebra. -}
+futu' :: forall f a. Difunctor f => CVCoalg' f a -> a -> Term f
+futu' coa x = run (x,[])
+    where run (a,bs) = run' $ coa a bs
+          run' (Term t) = Term $ fmap run' t
+          run' (Hole x) = run x
+          run' (Place p) = Place p
+
+-------------------------------------------
+-- functions only used for rewrite rules --
+-------------------------------------------
+
+appAlgTermHom :: forall f g d . (Difunctor g) => Alg g d -> TermHom f g -> Term f -> d
+{-# NOINLINE [1] appAlgTermHom #-}
+appAlgTermHom alg hom = run . coerceCxt where
+    run :: Trm f d -> d
+    run (Term t) = run' $ hom t
+    run (Place a) = a
+    run' :: Context g d (Trm f d) -> d
+    run' (Term t) = alg $ fmap run' t
+    run' (Place a) = a
+    run' (Hole x) = run x
+
+
+-- | This function applies a signature function after a term homomorphism.
+appSigFunTermHom :: forall f g h. (Difunctor g)
+                 => SigFun g h -> TermHom f g -> CxtFun f h
+{-# NOINLINE [1] appSigFunTermHom #-}
+appSigFunTermHom f g = run where
+    run :: CxtFun f h
+    run (Term t) = run' $ g t
+    run (Place a) = Place a
+    run (Hole h) = Hole h
+    run' :: Context g a (Cxt h' f a b) -> Cxt h' h a b
+    run' (Term t) = Term $ f $ fmap run' t
+    run' (Place a) = Place a
+    run' (Hole h) = run h
+
+appAlgTermHomM :: forall m g f d . (Monad m, Ditraversable g m d)
+               => AlgM m g d -> TermHomM m f g -> Term f -> m d
+appAlgTermHomM alg hom = run . coerceCxt where 
+    run :: Trm f d -> m d
+    run (Term t) = run' =<< hom t
+    run (Place a) = return a
+    run' :: Context g d (Trm f d) -> m d
+    run' (Term t) = alg =<< dimapM run' t
+    run' (Place a) = return a
+    run' (Hole x) = run x
+
+
+
+appTermHomTermHomM :: forall m f g h . (Ditraversable g m Any, Difunctor h)
+                   => TermHomM m g h -> TermHomM m f g -> CxtFunM m f h
+appTermHomTermHomM f g = coerceCxtFunM run where
+    run :: CxtFunM' m f h
+    run (Term t) = run' =<< g t
+    run (Place a) = return $ Place a
+    run (Hole h) = return $ Hole h
+    run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b)
+    run' (Term t) = liftM appCxt $ f =<< dimapM run' t
+    run' (Place a) = return $ Place a
+    run' (Hole h) = run h
+
+appSigFunTermHomM :: forall m f g h . (Ditraversable g m Any)
+                   => SigFunM m g h -> TermHomM m f g -> CxtFunM m f h
+appSigFunTermHomM f g = coerceCxtFunM run where
+    run :: CxtFunM' m f h
+    run (Term t) = run' =<< g t
+    run (Place a) = return $ Place a
+    run (Hole h) = return $ Hole h
+    run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b)
+    run' (Term t) = liftM Term $ f =<< dimapM run' t
+    run' (Place a) = return $ Place a
+    run' (Hole h) = run h
+
+
+-------------------
+-- rewrite rules --
+-------------------
+
+#ifndef NO_RULES
+{-# RULES
+  "cata/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x.
+    cata a (appTermHom h x) = cata (compAlg a h) x;
+
+  "cata/appTermHom'" forall (a :: Alg g d) (h :: TermHom f g) x.
+    cata a (appTermHom' h x) = appAlgTermHom a h x;
+
+  "cata/appSigFun" forall (a :: Alg g d) (h :: SigFun f g) x.
+    cata a (appSigFun h x) = cata (compAlgSigFun a h) x;
+
+  "cata/appSigFun'" forall (a :: Alg g d) (h :: SigFun f g) x.
+    cata a (appSigFun' h x) = appAlgTermHom a (termHom h) x;
+
+  "cata/appSigFunTermHom" forall (f :: Alg f3 d) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    cata f (appSigFunTermHom g h x) = appAlgTermHom (compAlgSigFun f g) h x;
+
+  "appAlgTermHom/appTermHom" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appTermHom f x) = cata (compAlg a (compTermHom h f)) x;
+
+  "appAlgTermHom/appTermHom'" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appTermHom' f x) = appAlgTermHom a (compTermHom h f) x;
+
+  "appAlgTermHom/appSigFun" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appSigFun f x) = cata (compAlg a (compTermHomSigFun h f)) x;
+
+  "appAlgTermHom/appSigFun'" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.
+    appAlgTermHom a h (appSigFun' f x) = appAlgTermHom a (compTermHomSigFun h f) x;
+
+  "appAlgTermHom/appSigFunTermHom" forall (a :: Alg i d) (f :: TermHom f g) (g :: SigFun g h)
+                                          (h :: TermHom h i) x.
+    appAlgTermHom a h (appSigFunTermHom g f x)
+      = appAlgTermHom a (compTermHom (compTermHomSigFun h g) f) x;
+
+  "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;
+
+  "appTermHom'/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom' a (appTermHom' h x) = appTermHom' (compTermHom a h) x;
+
+  "appTermHom'/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom' a (appTermHom h x) = appTermHom (compTermHom a h) x;
+
+  "appTermHom/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom a (appTermHom' h x) = appTermHom' (compTermHom a h) x;
+    
+  "appSigFun/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun f (appSigFun g x) = appSigFun (compSigFun f g) x;
+
+  "appSigFun'/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun' f (appSigFun' g x) = appSigFun' (compSigFun f g) x;
+
+  "appSigFun/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun f (appSigFun' g x) = appSigFunTermHom f (termHom g) x;
+
+  "appSigFun'/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.
+    appSigFun' f (appSigFun g x) = appSigFun (compSigFun f g) x;
+
+  "appTermHom/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;
+
+  "appTermHom/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom f (appSigFun' g x) =  appTermHom' (compTermHomSigFun f g) x;
+
+  "appTermHom'/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom' f (appSigFun' g x) =  appTermHom' (compTermHomSigFun f g) x;
+
+  "appTermHom'/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.
+    appTermHom' f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;
+    
+  "appSigFun/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun f (appTermHom g x) = appSigFunTermHom f g x;
+
+  "appSigFun'/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun' f (appTermHom' g x) = appTermHom' (compSigFunTermHom f g) x;
+
+  "appSigFun/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun f (appTermHom' g x) = appSigFunTermHom f g x;
+
+  "appSigFun'/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.
+    appSigFun' f (appTermHom g x) = appTermHom (compSigFunTermHom f g) x;
+    
+  "appSigFunTermHom/appSigFun" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: SigFun f1 f2) x.
+    appSigFunTermHom f g (appSigFun h x)
+    = appSigFunTermHom f (compTermHomSigFun g h) x;
+
+  "appSigFunTermHom/appSigFun'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: SigFun f1 f2) x.
+    appSigFunTermHom f g (appSigFun' h x)
+    = appSigFunTermHom f (compTermHomSigFun g h) x;
+
+  "appSigFunTermHom/appTermHom" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFunTermHom f g (appTermHom h x)
+    = appSigFunTermHom f (compTermHom g h) x;
+
+  "appSigFunTermHom/appTermHom'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFunTermHom f g (appTermHom' h x)
+    = appSigFunTermHom f (compTermHom g h) x;
+
+  "appSigFun/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFun f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;
+
+  "appSigFun'/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appSigFun' f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;
+
+  "appTermHom/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appTermHom f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;
+
+  "appTermHom'/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)
+                                      (h :: TermHom f1 f2) x.
+    appTermHom' f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;
+
+  "appSigFunTermHom/appSigFunTermHom" forall (f1 :: SigFun f4 f5) (f2 :: TermHom f3 f4)
+                                             (f3 :: SigFun f2 f3) (f4 :: TermHom f1 f2) x.
+    appSigFunTermHom f1 f2 (appSigFunTermHom f3 f4 x)
+      = appSigFunTermHom f1 (compTermHom (compTermHomSigFun f2 f3) f4) x;
+ #-}
+
+{-# RULES 
+  "cataM/appTermHomM" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= cataM a =  appAlgTermHomM a h x;
+
+  "cataM/appTermHomM'" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= cataM a = appAlgTermHomM a h x;
+
+  "cataM/appSigFunM" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= cataM a =  appAlgTermHomM a (termHomM h) x;
+
+  "cataM/appSigFunM'" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= cataM a = appAlgTermHomM a (termHomM h) x;
+
+  "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.
+     cataM a (appTermHom h x) = appAlgTermHomM a (sigFunM h) x;
+
+  "cataM/appTermHom'" forall (a :: AlgM m g d) (h :: TermHom f g) x.
+     cataM a (appTermHom' h x) = appAlgTermHomM a (sigFunM h) x;
+
+  "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.
+     cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;
+
+  "cataM/appSigFun'" forall (a :: AlgM m g d) (h :: SigFun f g) x.
+     cataM a (appSigFun' h x) = appAlgTermHomM a (sigFunM $ termHom h) x;
+
+  "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.
+     cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;
+
+  "cataM/appSigFunTermHom" forall (a :: AlgM m h d) (g :: SigFun g h) (f :: TermHom f g) x.
+     cataM a (appSigFunTermHom g f x) = appAlgTermHomM a (sigFunM $ compSigFunTermHom g f) x;
+
+  "appTermHomM/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;
+
+  "appTermHomM/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appTermHomM a = appTermHomM (compTermHomSigFunM a h) x;
+
+  "appTermHomM/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appTermHomM a = appTermHomTermHomM a h x;
+
+  "appTermHomM/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appTermHomM a = appTermHomTermHomM a (termHomM h) x;
+
+  "appTermHomM'/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;
+
+  "appTermHomM'/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;
+
+  "appTermHomM'/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;
+
+  "appTermHomM'/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;
+
+  "appTermHomM/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM a (appTermHom h x) = appTermHomTermHomM a (sigFunM h) x;
+
+  "appTermHomM/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM a (appSigFun h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;
+
+  "appTermHomM'/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM' a (appTermHom h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;
+
+  "appTermHomM'/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM' a (appSigFun h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;
+
+  "appTermHomM/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM a (appTermHom' h x) = appTermHomTermHomM a (sigFunM h) x;
+
+  "appTermHomM/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM a (appSigFun' h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;
+
+  "appTermHomM'/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.
+     appTermHomM' a (appTermHom' h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;
+
+  "appTermHomM'/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.
+     appTermHomM' a (appSigFun' h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;
+
+  "appSigFunM/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appSigFunM a = appSigFunTermHomM a h x;
+
+  "appSigFunHomM/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appSigFunM a = appSigFunM (compSigFunM a h) x;
+
+  "appSigFunM/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appSigFunM a = appSigFunTermHomM a h x;
+
+  "appSigFunM/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appSigFunM a = appSigFunTermHomM a (termHomM h) x;
+
+  "appSigFunM'/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' a h) x;
+
+  "appSigFunM'/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x;
+
+  "appSigFunM'/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.
+     appTermHomM' h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' a h) x;
+
+  "appSigFunM'/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.
+     appSigFunM' h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x;
+
+  "appSigFunM/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM a (appTermHom h x) = appSigFunTermHomM a (sigFunM h) x;
+
+  "appSigFunM/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM a (appSigFun h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;
+
+  "appSigFunM'/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM' a (appTermHom h x) = appTermHomM' (compSigFunTermHomM' a (sigFunM h)) x;
+
+  "appSigFunM'/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM' a (appSigFun h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;
+
+  "appSigFunM/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM a (appTermHom' h x) = appSigFunTermHomM a (sigFunM h) x;
+
+  "appSigFunM/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM a (appSigFun' h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;
+
+  "appSigFunM'/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.
+     appSigFunM' a (appTermHom' h x) = appTermHomM' (compSigFunTermHomM' a (sigFunM h)) x;
+
+  "appSigFunM'/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.
+     appSigFunM' a (appSigFun' h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;
+
+
+  "appTermHom/appTermHomM" forall (a :: TermHom g h) (h :: TermHomM m f g) x.
+     appTermHomM h x >>= (return . appTermHom a) = appTermHomM (compTermHomM_ a h) x;
+ #-}
+#endif
diff --git a/src/Data/Comp/Param/Annotation.hs b/src/Data/Comp/Param/Annotation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Annotation.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, RankNTypes, GADTs, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Annotation
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines annotations on signatures.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Annotation
+    (
+     (:&:) (..),
+     (:*:) (..),
+     DistAnn (..),
+     RemA (..),
+     liftA,
+     liftA',
+     stripA,
+     propAnn,
+     propAnnM,
+     ann,
+     project'
+    ) where
+
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Term
+import Data.Comp.Param.Sum
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Algebra
+
+import Control.Monad
+
+{-| Transform a function with a domain constructed from a functor to a function
+ with a domain constructed with the same functor, but with an additional
+ annotation. -}
+liftA :: (RemA s s') => (s' a b -> t) -> s a b -> t
+liftA f v = f (remA v)
+
+{-| Transform a function with a domain constructed from a functor to a function
+  with a domain constructed with the same functor, but with an additional
+  annotation. -}
+liftA' :: (DistAnn s' p s, Difunctor s')
+          => (s' a b -> Cxt h s' c d) -> s a b -> Cxt h s c d
+liftA' f v = let (v',p) = projectA v
+             in ann p (f v')
+
+{-| Strip the annotations from a term over a functor with annotations. -}
+stripA :: (RemA g f, Difunctor g) => CxtFun g f
+stripA = appSigFun remA
+
+{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism
+ over the same signatures, but extended with annotations. -}
+propAnn :: (DistAnn f p f', DistAnn g p g', Difunctor g) 
+        => TermHom f g -> TermHom f' g'
+propAnn hom f' = ann p (hom f)
+    where (f,p) = projectA f'
+
+{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic
+  term homomorphism over the same signatures, but extended with annotations. -}
+propAnnM :: (DistAnn f p f', DistAnn g p g', Difunctor g, Monad m) 
+         => TermHomM m f g -> TermHomM m f' g'
+propAnnM hom f' = liftM (ann p) (hom f)
+    where (f,p) = projectA f'
+
+{-| Annotate each node of a term with a constant value. -}
+ann :: (DistAnn f p g, Difunctor f)  => p -> CxtFun f g
+ann c = appSigFun (injectA c)
+
+{-| This function is similar to 'project' but applies to signatures
+with an annotation which is then ignored. -}
+-- bug in type checker? below is the inferred type, however, the type checker
+-- rejects it.
+-- project' :: (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))
+project' v = liftM remA $ project v
diff --git a/src/Data/Comp/Param/Any.hs b/src/Data/Comp/Param/Any.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Any.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE EmptyDataDecls #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Any
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the empty data type 'Any', which is used to emulate
+-- parametricity (\"poor mans parametricity\").
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Any
+    (
+     Any
+    ) where
+
+-- |The empty data type 'Any' is used to emulate parametricity
+-- (\"poor mans parametricity\").
+data Any
diff --git a/src/Data/Comp/Param/Derive.hs b/src/Data/Comp/Param/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive.hs
@@ -0,0 +1,48 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module contains functionality for automatically deriving boilerplate
+-- code using Template Haskell. Examples include instances of 'Difunctor',
+-- 'Difoldable', and 'Ditraversable'.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive
+    (
+     derive,
+     -- |Derive boilerplate instances for parametric signatures, i.e.
+     -- signatures for parametric compositional data types.
+
+     -- ** EqD
+     module Data.Comp.Param.Derive.Equality,
+     -- ** OrdD
+     module Data.Comp.Param.Derive.Ordering,
+     -- ** ShowD
+     module Data.Comp.Param.Derive.Show,
+     -- ** Difunctor
+     module Data.Comp.Param.Derive.Difunctor,
+     -- ** Ditraversable
+     module Data.Comp.Param.Derive.Ditraversable,
+     -- ** Smart Constructors
+     module Data.Comp.Param.Derive.SmartConstructors,
+     -- ** Smart Constructors w/ Annotations
+     module Data.Comp.Param.Derive.SmartAConstructors,
+     -- ** Lifting to Sums
+     module Data.Comp.Param.Derive.LiftSum
+    ) where
+
+import Data.Comp.Derive.Utils (derive)
+import Data.Comp.Param.Derive.Equality
+import Data.Comp.Param.Derive.Ordering
+import Data.Comp.Param.Derive.Show
+import Data.Comp.Param.Derive.Difunctor
+import Data.Comp.Param.Derive.Ditraversable
+import Data.Comp.Param.Derive.SmartConstructors
+import Data.Comp.Param.Derive.SmartAConstructors
+import Data.Comp.Param.Derive.LiftSum
diff --git a/src/Data/Comp/Param/Derive/Difunctor.hs b/src/Data/Comp/Param/Derive/Difunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Difunctor.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Functor
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @Difunctor@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.Difunctor
+    (
+     Difunctor,
+     makeDifunctor
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.Difunctor
+import Language.Haskell.TH
+
+{-| Derive an instance of 'Difunctor' for a type constructor of any parametric
+  kind taking at least two arguments. -}
+makeDifunctor :: Name -> Q [Dec]
+makeDifunctor fname = do
+  -- Comments below apply to the example where name = T, args = [a,b,c], and
+  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type
+  -- declaration: T a b c = X c | Y a c | Z (b -> c)
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  -- coArg = c (covariant difunctor argument)
+  let coArg :: Name = tyVarBndrName $ last args
+  -- conArg = b (contravariant difunctor argument)
+  let conArg :: Name = tyVarBndrName $ last $ init args
+  -- argNames = [a]
+  let argNames = map (VarT . tyVarBndrName) (init $ init args)
+  -- compType = T a
+  let complType = foldl AppT (ConT name) argNames
+  -- classType = Difunctor (T a)
+  let classType = AppT (ConT ''Difunctor) complType
+  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  dimapDecl <- funD 'dimap (map (dimapClause conArg coArg) constrs')
+  return [InstanceD [] classType [dimapDecl]]
+      where dimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            dimapClause conArg coArg (constr, args) = do
+              fn <- newName "_f"
+              gn <- newName "_g"
+              varNs <- newNames (length args) "x"
+              let f = varE fn
+              let g = varE gn
+              let fp = VarP fn
+              let gp = VarP gn
+              -- Pattern for the constructor
+              let pat = ConP constr $ map VarP varNs
+              body <- dimapArgs conArg coArg f g (zip varNs args) (conE constr)
+              return $ Clause [fp, gp, pat] (NormalB body) []
+            dimapArgs :: Name -> Name -> ExpQ -> ExpQ
+                      -> [(Name, Type)] -> ExpQ -> ExpQ
+            dimapArgs _ _ _ _ [] acc =
+                acc
+            dimapArgs conArg coArg f g ((x,tp):tps) acc =
+                dimapArgs conArg coArg f g tps
+                          (acc `appE` (dimapArg conArg coArg tp f g `appE` varE x))
+            -- Given the name of the difunctor variables, a type, and the two
+            -- arguments to dimap, return the expression that should be applied
+            -- to the parameter of the given type.
+            -- Example: dimapArg a b (a -> b) f g yields the expression
+            -- [|\x -> g . x . f|]
+            dimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ
+            dimapArg conArg coArg tp f g
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) = [| id |]
+                | otherwise =
+                    case tp of
+                      VarT a | a == conArg -> f
+                             | a == coArg -> g
+                      AppT (AppT ArrowT tp1) tp2 -> do
+                          xn <- newName "x"
+                          let ftp1 = dimapArg conArg coArg tp1 f g
+                          let ftp2 = dimapArg conArg coArg tp2 f g
+                          lamE [varP xn]
+                               (infixE (Just ftp2)
+                                       [|(.)|]
+                                       (Just $ infixE (Just $ varE xn)
+                                                      [|(.)|]
+                                                      (Just ftp1)))
+                      SigT tp' _ ->
+                          dimapArg conArg coArg tp' f g
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| dimap $f $g |]
+                          else
+                              [| fmap $g |]
diff --git a/src/Data/Comp/Param/Derive/Ditraversable.hs b/src/Data/Comp/Param/Derive/Ditraversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Ditraversable.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Ditraversable
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @Ditraversable@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.Ditraversable
+    (
+     Ditraversable,
+     makeDitraversable
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.Ditraversable
+import Data.Traversable (mapM)
+import Language.Haskell.TH
+import Data.Maybe
+import Control.Monad hiding (mapM)
+import Prelude hiding (mapM)
+
+iter 0 _ e = e
+iter n f e = iter (n-1) f (f `appE` e)
+
+iter' n f e = run n f e
+    where run 0 _ e = e
+          run m f e = let f' = iter (m-1) [|fmap|] f
+                        in run (m-1) f (f' `appE` e)
+
+{-| Derive an instance of 'Traversable' for a type constructor of any
+  first-order kind taking at least one argument. -}
+makeDitraversable :: Name -> Q [Dec]
+makeDitraversable fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  monadType <- varT =<< newName "m"
+  domainType <- varT =<< newName "d"
+  let fArg = VarT . tyVarBndrName $ last args
+      aArg = VarT . tyVarBndrName $ last (init args)
+      funTy = foldl AppT ArrowT [aArg,fArg]
+      argNames = (map (VarT . tyVarBndrName) (init $ init args))
+      complType = foldl AppT (ConT name) argNames
+      classType = foldl1 AppT [ConT ''Ditraversable, complType, monadType,domainType]
+  normConstrs <- mapM normalConExp constrs
+  let hasFunTy = or $ map (checksAarg funTy) normConstrs
+      context = [ClassP ''Monad [monadType]] ++
+                if hasFunTy
+                then [ClassP ''Ditraversable [ArrowT,monadType,domainType] ]
+                else []
+  constrs' <- mapM (mkPatAndVars . isFarg fArg funTy) normConstrs
+  mapMDecl <- funD 'dimapM (map mapMClause constrs')
+  sequenceDecl <- funD 'disequence (map sequenceClause constrs')
+  return [InstanceD context classType [mapMDecl,sequenceDecl]]
+      where isFarg fArg funTy (constr, args) =
+                (constr, map (\t -> (t `containsType'` fArg, t `containsType'` funTy)) args)
+            checksAarg aArg (_,args) = any (`containsType` aArg) args
+            filterVar _ _ nonFarg ([],[]) x  = nonFarg x
+            filterVar farg _ _ ([depth],[]) x = farg depth x
+            filterVar _ aarg _ ([_],[depth]) x = aarg depth x
+            filterVar _ _ _ _ _ = error "functor variable occurring twice in argument type"
+            filterVars args varNs farg aarg nonFarg = zipWith (filterVar farg aarg nonFarg) args varNs
+            mkCPat constr varNs = ConP constr $ map mkPat varNs
+            mkPat = VarP
+            mkPatAndVars (constr, args) =
+                do varNs <- newNames (length args) "x"
+                   return (conE constr, mkCPat constr varNs,
+                           any (not . null . fst) args || any (not . null . snd) args, map varE varNs,
+                           catMaybes $ filterVars args varNs (\x y -> Just (False,x,y)) (\x y -> Just (True, x, y)) (const Nothing))
+
+            -- Note: the monadic versions are not defined
+            -- applicatively, as this results in a considerable
+            -- performance penalty (by factor 2)!
+            mapMClause (con, pat,hasFargs,allVars, fvars) =
+                do fn <- newName "f"
+                   let f = varE fn
+                       fp = if hasFargs then VarP fn else WildP
+                       conAp = foldl appE con allVars
+                       addDi False _ x = x
+                       addDi True d x = [|dimapM $(f)|]
+                       conBind (fun,d,x) y = [| $(iter d [|mapM|] (addDi fun d f)) $(varE x)  >>= $(lamE [varP x] y)|]
+                   body <- foldr conBind [|return $conAp|] fvars
+                   return $ Clause [fp, pat] (NormalB body) []
+            sequenceClause (con, pat,hasFargs,allVars, fvars) =
+                do let conAp = foldl appE con allVars
+                       varE' False _ x = varE x
+                       varE' True d x = appE (iter d [|fmap|] [|disequence|]) (varE x)
+                       conBind (fun,d, x) y = [| $(iter' d [|sequence|] (varE' fun d x))  >>= $(lamE [varP x] y)|]
+                   body <- foldr conBind [|return $conAp|] fvars
+                   return $ Clause [pat] (NormalB body) []
diff --git a/src/Data/Comp/Param/Derive/Equality.hs b/src/Data/Comp/Param/Derive/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Equality.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
+  ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Equality
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @EqD@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.Derive.Equality
+    (
+     EqD(..),
+     makeEqD
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.FreshM
+import Data.Comp.Param.Equality
+import Control.Monad
+import Language.Haskell.TH hiding (Cxt, match)
+
+{-| Derive an instance of 'EqD' for a type constructor of any parametric
+  kind taking at least two arguments. -}
+makeEqD :: Name -> Q [Dec]
+makeEqD fname = do
+  -- Comments below apply to the example where name = T, args = [a,b,c], and
+  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type
+  -- declaration: T a b c = X c | Y a c | Z (b -> c)
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  -- coArg = c (covariant difunctor argument)
+  let coArg :: Name = tyVarBndrName $ last args
+  -- conArg = b (contravariant difunctor argument)
+  let conArg :: Name = tyVarBndrName $ last $ init args
+  -- argNames = [a]
+  let argNames = map (VarT . tyVarBndrName) (init $ init args)
+  -- compType = T a
+  let complType = foldl AppT (ConT name) argNames
+  -- classType = Difunctor (T a)
+  let classType = AppT (ConT ''EqD) complType
+  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  let defC = if length constrs < 2 then
+                 []
+             else
+                 [clause [wildP,wildP] (normalB [|return False|]) []]
+  eqDDecl <- funD 'eqD (map (eqDClause conArg coArg) constrs' ++ defC)
+  return [InstanceD [] classType [eqDDecl]]
+      where eqDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            eqDClause conArg coArg (constr, args) = do
+              varXs <- newNames (length args) "x"
+              varYs <- newNames (length args) "y"
+              -- Patterns for the constructors
+              let patx = ConP constr $ map VarP varXs
+              let paty = ConP constr $ map VarP varYs
+              body <- eqDBody conArg coArg (zip3 varXs varYs args)
+              return $ Clause [patx,paty] (NormalB body) []
+            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ
+            eqDBody conArg coArg x =
+                [|liftM and (sequence $(listE $ map (eqDB conArg coArg) x))|]
+            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ
+            eqDB conArg coArg (x, y, tp)
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) =
+                    [| return $ $(varE x) == $(varE y) |]
+                | otherwise =
+                    case tp of
+                      VarT a
+                          | a == coArg -> [| peq $(varE x) $(varE y) |]
+                      AppT (AppT ArrowT (VarT a)) _
+                          | a == conArg ->
+                              [| do {v <- genVar;
+                                     peq ($(varE x) v) ($(varE y) v)} |]
+                      SigT tp' _ ->
+                          eqDB conArg coArg (x, y, tp')
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| eqD $(varE x) $(varE y) |]
+                          else
+                              [| peq $(varE x) $(varE y) |]
diff --git a/src/Data/Comp/Param/Derive/Injections.hs b/src/Data/Comp/Param/Derive/Injections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Injections.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Injections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature injections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.Injections
+    (
+     injn,
+     injectn,
+     deepInjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Term
+import Data.Comp.Param.Algebra (CxtFun, appSigFun)
+import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..))
+
+injn :: Int -> Q [Dec]
+injn n = do
+  let i = mkName $ "inj" ++ show n
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let xvar = mkName "x"
+  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar bvar) : d
+    where genSig fvars gvar avar bvar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT bvar)
+                             `appT` (varT gvar `appT` varT avar `appT`
+                                     varT bvar)
+            forallT (map PlainTV $ gvar : avar : bvar : fvars)
+                    (sequence cxt) tp'
+          genDecl x n = [| case $(varE x) of
+                             Inl x -> $(varE $ mkName $ "inj") x
+                             Inr x -> $(varE $ mkName $ "inj" ++
+                                        if n > 2 then show (n - 1) else "") x |]
+injectn :: Int -> Q [Dec]
+injectn n = do
+  let i = mkName ("inject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar avar bvar) : d
+    where genSig fvars gvar avar bvar = do
+            let hvar = mkName "h"
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar
+                                 `appT` varT avar `appT` varT bvar
+            let tp'' = arrowT `appT` (tp `appT` varT avar `appT` tp') `appT` tp'
+            forallT (map PlainTV $ hvar : gvar : avar : bvar : fvars)
+                    (sequence cxt) tp''
+          genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]
+
+deepInjectn :: Int -> Q [Dec]
+deepInjectn n = do
+  let i = mkName ("deepInject" ++ show n)
+  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]
+  let gvar = mkName "g"
+  let d = [funD i [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD i $ genSig fvars gvar) : d
+    where genSig fvars gvar = do
+            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars
+            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)
+                            (map varT fvars)
+            let cxt' = classP ''Difunctor [tp]
+            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar
+            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
diff --git a/src/Data/Comp/Param/Derive/LiftSum.hs b/src/Data/Comp/Param/Derive/LiftSum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/LiftSum.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.LiftSum
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Lift a class declaration for difunctors to sums of difunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.LiftSum
+    (
+     liftSum,
+     caseD
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.Sum
+import Data.Comp.Param.Ops ((:+:)(..))
+
+{-| Given the name of a type class, where the first parameter is a difunctor,
+  lift it to sums of difunctors. Example: @class ShowD f where ...@ is lifted
+  as @instance (ShowD f, ShowD g) => ShowD (f :+: g) where ... @. -}
+liftSum :: Name -> Q [Dec]
+liftSum fname = do
+  ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname
+  let targs' = map tyVarBndrName $ tail targs
+  let f = mkName "f"
+  let g = mkName "g"
+  let cxt = [ClassP name (map VarT $ f : targs'),
+             ClassP name (map VarT $ g : targs')]
+  let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)
+  let complType = foldl (\a x -> a `AppT` VarT x) tp targs'
+  decs' <- sequence $ concatMap decl decs
+  return [InstanceD cxt complType decs']
+      where decl :: Dec -> [DecQ]
+            decl (SigD f _) = [funD f [clause f]]
+            decl _ = []
+            clause :: Name -> ClauseQ
+            clause f = do x <- newName "x"
+                          b <- normalB [|caseD $(varE f) $(varE f) $(varE x)|]
+                          return $ Clause [VarP x] b []
+
+{-| Utility function to case on a difunctor sum, without exposing the internal
+  representation of sums. -}
+caseD :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c
+caseD f g x = case x of
+                Inl x -> f x
+                Inr x -> g x
diff --git a/src/Data/Comp/Param/Derive/Ordering.hs b/src/Data/Comp/Param/Derive/Ordering.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Ordering.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
+  ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Ordering
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @OrdD@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.Derive.Ordering
+    (
+     OrdD(..),
+     makeOrdD
+    ) where
+
+import Data.Comp.Param.FreshM
+import Data.Comp.Param.Ordering
+import Data.Comp.Derive.Utils
+import Data.Maybe
+import Data.List
+import Language.Haskell.TH hiding (Cxt)
+import Control.Monad (liftM)
+
+compList :: [Ordering] -> Ordering
+compList = fromMaybe EQ . find (/= EQ)
+
+{-| Derive an instance of 'OrdD' for a type constructor of any parametric
+  kind taking at least two arguments. -}
+makeOrdD :: Name -> Q [Dec]
+makeOrdD fname = do
+  -- Comments below apply to the example where name = T, args = [a,b,c], and
+  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type
+  -- declaration: T a b c = X c | Y a c | Z (b -> c)
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  -- coArg = c (covariant difunctor argument)
+  let coArg :: Name = tyVarBndrName $ last args
+  -- conArg = b (contravariant difunctor argument)
+  let conArg :: Name = tyVarBndrName $ last $ init args
+  -- argNames = [a]
+  let argNames = map (VarT . tyVarBndrName) (init $ init args)
+  -- compType = T a
+  let complType = foldl AppT (ConT name) argNames
+  -- classType = Difunctor (T a)
+  let classType = AppT (ConT ''OrdD) complType
+  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  compareDDecl <- funD 'compareD (compareDClauses conArg coArg constrs')
+  return [InstanceD [] classType [compareDDecl]]
+      where compareDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ]
+            compareDClauses _ _ [] = []
+            compareDClauses conArg coArg constrs = 
+                let constrs' = constrs `zip` [1..]
+                    constPairs = [(x,y)| x<-constrs', y <- constrs']
+                in map (genClause conArg coArg) constPairs
+            genClause conArg coArg ((c,n),(d,m))
+                | n == m = genEqClause conArg coArg c
+                | n < m = genLtClause c d
+                | otherwise = genGtClause c d
+            genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            genEqClause conArg coArg (constr, args) = do 
+              varXs <- newNames (length args) "x"
+              varYs <- newNames (length args) "y"
+              let patX = ConP constr $ map VarP varXs
+              let patY = ConP constr $ map VarP varYs
+              body <- eqDBody conArg coArg (zip3 varXs varYs args)
+              return $ Clause [patX, patY] (NormalB body) []
+            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ
+            eqDBody conArg coArg x =
+                [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]
+            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ
+            eqDB conArg coArg (x, y, tp)
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) =
+                    [| return $ compare $(varE x) $(varE y) |]
+                | otherwise =
+                    case tp of
+                      VarT a
+                          | a == coArg -> [| pcompare $(varE x) $(varE y) |]
+                      AppT (AppT ArrowT (VarT a)) _
+                          | a == conArg ->
+                              [| do {v <- genVar;
+                                     pcompare ($(varE x) v) ($(varE y) v)} |]
+                      SigT tp' _ ->
+                          eqDB conArg coArg (x, y, tp')
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| compareD $(varE x) $(varE y) |]
+                          else
+                              [| pcompare $(varE x) $(varE y) |]
+            genLtClause (c, _) (d, _) =
+                clause [recP c [], recP d []] (normalB [| return LT |]) []
+            genGtClause (c, _) (d, _) =
+                clause [recP c [], recP d []] (normalB [| return GT |]) []
diff --git a/src/Data/Comp/Param/Derive/Projections.hs b/src/Data/Comp/Param/Derive/Projections.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Projections.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE TemplateHaskell, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Projections
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Derive functions for signature projections.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.Projections
+    (
+     projn,
+     projectn,
+     deepProjectn
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Control.Monad (liftM)
+import Data.Comp.Param.Ditraversable (Ditraversable)
+import Data.Comp.Param.Term
+import Data.Comp.Param.Algebra (CxtFunM, appSigFunM')
+import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..))
+
+projn :: Int -> Q [Dec]
+projn n = do
+  let p = mkName $ "proj" ++ show n
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar bvar) []]]
+  sequence $ (sigD p $ genSig gvars avar bvar) : d
+    where genSig gvars avar bvar = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = arrowT `appT` (varT fvar `appT` varT avar `appT`
+                                     varT bvar)
+                             `appT` (conT ''Maybe `appT`
+                                     (tp `appT` varT avar `appT` varT bvar))
+            forallT (map PlainTV $ fvar : avar : bvar : gvars)
+                    (sequence cxt) tp'
+          genDecl x [g] a b =
+            [| liftM inj (proj $(varE x)
+                          :: Maybe ($(varT g `appT` varT a `appT` varT b))) |]
+          genDecl x (g:gs) a b =
+            [| case (proj $(varE x)
+                         :: Maybe ($(varT g `appT` varT a `appT` varT b))) of
+                 Just y -> Just $ inj y
+                 _ -> $(genDecl x gs a b) |]
+          genDecl _ _ _ _ = error "genDecl called with empty list"
+
+projectn :: Int -> Q [Dec]
+projectn n = do
+  let p = mkName ("project" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let avar = mkName "a"
+  let bvar = mkName "b"
+  let xvar = mkName "x"
+  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]
+  sequence $ (sigD p $ genSig gvars avar bvar) : d
+    where genSig gvars avar bvar = do
+            let fvar = mkName "f"
+            let hvar = mkName "h"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar
+                                 `appT` varT avar `appT` varT bvar
+            let tp'' = arrowT `appT` tp'
+                              `appT` (conT ''Maybe `appT`
+                                      (tp `appT` varT avar `appT` tp'))
+            forallT (map PlainTV $ hvar : fvar : avar : bvar : gvars)
+                    (sequence cxt) tp''
+          genDecl x n = [| case $(varE x) of
+                             Hole _ -> Nothing
+                             Place _ -> Nothing
+                             Term t -> $(varE $ mkName $ "proj" ++ show n) t |]
+
+deepProjectn :: Int -> Q [Dec]
+deepProjectn n = do
+  let p = mkName ("deepProject" ++ show n)
+  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]
+  let d = [funD p [clause [] (normalB $ genDecl n) []]]
+  sequence $ (sigD p $ genSig gvars) : d
+    where genSig gvars = do
+            let fvar = mkName "f"
+            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars
+            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)
+                            (map varT gvars)
+            let cxt' = classP ''Ditraversable [tp, conT ''Maybe, conT ''Any]
+            let tp' = conT ''CxtFunM `appT` conT ''Maybe
+                                     `appT` varT fvar `appT` tp
+            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'
+          genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
diff --git a/src/Data/Comp/Param/Derive/Show.hs b/src/Data/Comp/Param/Derive/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/Show.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,
+  ScopedTypeVariables, UndecidableInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.Show
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @ShowD@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.Derive.Show
+    (
+     PShow(..),
+     ShowD(..),
+     makeShowD
+    ) where
+
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.FreshM
+import Control.Monad
+import Language.Haskell.TH hiding (Cxt, match)
+
+-- |Printing of parametric values.
+class PShow a where
+    pshow :: a -> FreshM String
+
+{-| Signature printing. An instance @ShowD f@ gives rise to an instance
+  @Show (Term f)@. -}
+class ShowD f where
+    showD :: PShow a => f Var a -> FreshM String
+
+{-| Derive an instance of 'ShowD' for a type constructor of any parametric
+  kind taking at least two arguments. -}
+makeShowD :: Name -> Q [Dec]
+makeShowD fname = do
+  -- Comments below apply to the example where name = T, args = [a,b,c], and
+  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type
+  -- declaration: T a b c = X c | Y a c | Z (b -> c)
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  -- coArg = c (covariant difunctor argument)
+  let coArg :: Name = tyVarBndrName $ last args
+  -- conArg = b (contravariant difunctor argument)
+  let conArg :: Name = tyVarBndrName $ last $ init args
+  -- argNames = [a]
+  let argNames = map (VarT . tyVarBndrName) (init $ init args)
+  -- compType = T a
+  let complType = foldl AppT (ConT name) argNames
+  -- classType = Difunctor (T a)
+  let classType = AppT (ConT ''ShowD) complType
+  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  showDDecl <- funD 'showD (map (showDClause conArg coArg) constrs')
+  return [InstanceD [] classType [showDDecl]]
+      where showDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ
+            showDClause conArg coArg (constr, args) = do
+              varXs <- newNames (length args) "x"
+              -- Pattern for the constructor
+              let patx = ConP constr $ map VarP varXs
+              body <- showDBody (nameBase constr) conArg coArg (zip varXs args)
+              return $ Clause [patx] (NormalB body) []
+            showDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ
+            showDBody constr conArg coArg x =
+                [|liftM (unwords . (constr :) .
+                         map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x))
+                        (sequence $(listE $ map (showDB conArg coArg) x))|]
+            showDB :: Name -> Name -> (Name, Type) -> ExpQ
+            showDB conArg coArg (x, tp)
+                | not (containsType tp (VarT conArg)) &&
+                  not (containsType tp (VarT coArg)) =
+                    [| return $ show $(varE x) |]
+                | otherwise =
+                    case tp of
+                      VarT a
+                          | a == coArg -> [| pshow $(varE x) |]
+                      AppT (AppT ArrowT (VarT a)) _
+                          | a == conArg ->
+                              [| do {v <- genVar;
+                                     body <- pshow $ $(varE x) v;
+                                     return $ "\\" ++ show v ++ " -> " ++ body} |]
+                      SigT tp' _ ->
+                          showDB conArg coArg (x, tp')
+                      _ ->
+                          if containsType tp (VarT conArg) then
+                              [| showD $(varE x) |]
+                          else
+                              [| pshow $(varE x) |]
diff --git a/src/Data/Comp/Param/Derive/SmartAConstructors.hs b/src/Data/Comp/Param/Derive/SmartAConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/SmartAConstructors.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.SmartAConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors with annotations.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.SmartAConstructors 
+    (
+     smartAConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Term
+
+import Control.Monad
+
+{-| Derive smart constructors with products for a type constructor of any
+  parametric kind taking at least two arguments. The smart constructors are
+  similar to the ordinary constructors, but an 'injectA' is automatically
+  inserted. -}
+smartAConstructors :: Name -> Q [Dec]
+smartAConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let cons = map abstractConType constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where genSmartConstr targs tname (name, args) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args
+              genSmartConstr' targs tname sname name args = do
+                varNs <- newNames args "x"
+                varPr <- newName "_p"
+                let pats = map varP (varPr : varNs)
+                    vars = map varE varNs
+                    val = appE [|injectA $(varE varPr)|] $
+                          appE [|inj|] $ foldl appE (conE name) vars
+                    function = [funD sname [clause pats (normalB [|Term $val|]) []]]
+                sequence function
diff --git a/src/Data/Comp/Param/Derive/SmartConstructors.hs b/src/Data/Comp/Param/Derive/SmartConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Derive/SmartConstructors.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Derive.SmartConstructors
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors for parametric types.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Derive.SmartConstructors 
+    (
+     smartConstructors
+    ) where
+
+import Language.Haskell.TH hiding (Cxt)
+import Data.Comp.Derive.Utils
+import Data.Comp.Param.Sum
+import Data.Comp.Param.Term
+import Control.Monad
+
+{-| Derive smart constructors for a type constructor of any parametric kind
+ taking at least two arguments. The smart constructors are similar to the
+ ordinary constructors, but an 'inject' is automatically inserted. -}
+smartConstructors :: Name -> Q [Dec]
+smartConstructors fname = do
+    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname
+    let cons = map abstractConType constrs
+    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons
+        where genSmartConstr targs tname (name, args) = do
+                let bname = nameBase name
+                genSmartConstr' targs tname (mkName $ 'i' : bname) name args
+              genSmartConstr' targs tname sname name args = do
+                varNs <- newNames args "x"
+                let pats = map varP varNs
+                    vars = map varE varNs
+                    val = foldl appE (conE name) vars
+                    sig = genSig targs tname sname args
+                    function = [funD sname [clause pats (normalB [|inject $val|]) []]]
+                sequence $ sig ++ function
+              genSig targs tname sname 0 = (:[]) $ do
+                hvar <- newName "h"
+                fvar <- newName "f"
+                avar <- newName "a"
+                bvar <- newName "b"
+                let targs' = init $ init targs
+                    vars = hvar:fvar:avar:bvar:targs'
+                    h = varT hvar
+                    f = varT fvar
+                    a = varT avar
+                    b = varT bvar
+                    ftype = foldl appT (conT tname) (map varT targs')
+                    constr = classP ''(:<:) [ftype, f]
+                    typ = foldl appT (conT ''Cxt) [h, f, a, b]
+                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ
+                sigD sname typeSig
+              genSig _ _ _ _ = []
diff --git a/src/Data/Comp/Param/Desugar.hs b/src/Data/Comp/Param/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Desugar.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,
+  UndecidableInstances, OverlappingInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Desugar
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This modules defines the 'Desugar' type class for desugaring of terms.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Desugar where
+
+import Data.Comp.Param
+import Data.Comp.Param.Derive
+
+-- |The desugaring term homomorphism.
+class (Difunctor f, Difunctor g) => Desugar f g where
+    desugHom :: TermHom f g
+    desugHom = desugHom' . fmap Hole
+    desugHom' :: f a (Cxt h g a b) -> Cxt h g a b
+    desugHom' x = appCxt (desugHom x)
+
+$(derive [liftSum] [''Desugar])
+
+-- |Desugar a term.
+desugar :: Desugar f g => Term f -> Term g
+{-# INLINE desugar #-}
+desugar = appTermHom desugHom
+
+-- |Lift desugaring to annotated terms.
+desugarA :: (Difunctor f', Difunctor g', DistAnn f p f', DistAnn g p g',
+             Desugar f g) => Term f' -> Term g'
+desugarA = appTermHom (propAnn desugHom)
+
+-- |Default desugaring instance.
+instance (Difunctor f, Difunctor g, f :<: g) => Desugar f g where
+    desugHom = simpCxt . inj
diff --git a/src/Data/Comp/Param/Difunctor.hs b/src/Data/Comp/Param/Difunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Difunctor.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Difunctor
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines difunctors (Meijer, Hutton, FPCA '95), i.e. binary type
+-- constructors that are contravariant in the first argument and covariant in
+-- the second argument.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Difunctor
+    (
+     Difunctor (..)
+    ) where
+
+-- | This class represents difunctors, i.e. binary type constructors that are
+-- contravariant in the first argument and covariant in the second argument.
+class Difunctor f where
+    dimap :: (a -> b) -> (c -> d) -> f b c -> f a d
+
+{-| The canonical example of a difunctor. -}
+instance Difunctor (->) where
+    dimap f g h = g . h . f
+
+instance Difunctor f => Functor (f a) where
+    fmap = dimap id
diff --git a/src/Data/Comp/Param/Ditraversable.hs b/src/Data/Comp/Param/Ditraversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Ditraversable.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses,
+  FlexibleContexts, OverlappingInstances  #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Ditraversable
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines traversable difunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Ditraversable
+    (
+     Ditraversable(..)
+    ) where
+
+import Prelude hiding (mapM, sequence, foldr)
+import Data.Maybe (fromJust)
+import Data.Comp.Param.Any
+import Data.Comp.Param.Difunctor
+import Test.QuickCheck.Gen
+import Data.Functor.Identity
+import Control.Monad.Reader hiding (mapM, sequence)
+import Control.Monad.Error hiding (mapM, sequence)
+import Control.Monad.State hiding (mapM, sequence)
+import Control.Monad.List hiding (mapM, sequence)
+import Control.Monad.RWS hiding (Any, mapM, sequence)
+import Control.Monad.Writer hiding (Any, mapM, sequence)
+
+{-| Difunctors representing data structures that can be traversed from left to
+  right. -}
+class (Difunctor f, Monad m) => Ditraversable f m a where
+    dimapM :: (b -> m c) -> f a b -> m (f a c)
+    dimapM f = disequence . fmap f
+
+    disequence :: f a (m b) -> m (f a b)
+    disequence = dimapM id
+
+
+instance Ditraversable (->) Gen a where
+    dimapM f s = MkGen run
+        where run stdGen seed a = unGen (f (s a)) stdGen seed
+    disequence s = MkGen run
+        where run stdGen seed a = unGen (s a) stdGen seed
+
+instance Ditraversable (->) Identity a where
+    dimapM f s = Identity run
+        where run a = runIdentity (f (s a))
+    disequence s = Identity run
+        where run a = runIdentity (s a)
+
+instance Ditraversable (->) m a =>  Ditraversable (->) (ReaderT r m) a where
+    dimapM f s = ReaderT (disequence . run)
+        where run r a = runReaderT (f (s a)) r
+    disequence s = ReaderT (disequence . run)
+        where run r a = runReaderT (s a) r
+
+
+{-| Functions of the type @Any -> Maybe a@ can be turned into functions of
+ type @Maybe (Any -> a)@. The empty type @Any@ ensures that the function
+ is parametric in the input, and hence the @Maybe@ monad can be pulled out. -}
+instance Ditraversable (->) Maybe Any where
+    dimapM f g = disequence (f .g)
+    disequence f = do _ <- f undefined
+                      return $ \x -> fromJust $ f x
+
+
+instance Ditraversable (->) (Either e) Any where
+    dimapM f g = disequence (f . g)
+    disequence h = case h undefined of
+                   Left e -> Left e
+                   Right _ -> Right $ fromRight . h
+        where fromRight (Right x) = x
+              fromRight (Left _) = error "fromRight: expected Right"
+
+instance (Error e, Ditraversable (->) m Any) => Ditraversable (->) (ErrorT e m) Any where
+    dimapM f g = disequence (f . g)
+    disequence h = ErrorT $
+                 do r <- runErrorT (h undefined) 
+                    case r of
+                      Left e -> return $ Left e
+                      Right _ -> liftM Right $ disequence (liftM fromRight . runErrorT . h) 
+        where fromRight (Right x) = x
+              fromRight (Left _) = error "fromRight: expected Right"
+
+instance (Ditraversable (->) m Any) => Ditraversable (->) (StateT s m) Any where
+    dimapM f g = disequence (f . g)
+    disequence h = StateT trans
+        where trans s = 
+                  do (_,s') <- runStateT (h undefined) s
+                     fun <-  disequence (liftM fst . (`runStateT` s) . h)
+                     return (fun,s')
+
+instance (Monoid w, Ditraversable (->) m Any) => Ditraversable (->) (WriterT w m) Any where
+    dimapM f g = disequence (f . g)
+    disequence h = WriterT trans
+        where trans = 
+                  do (_,w) <- runWriterT (h undefined)
+                     fun <-  disequence (liftM fst . runWriterT . h)
+                     return (fun,w)
+
+instance Ditraversable (->) [] Any where 
+    dimapM f g = disequence (f . g)
+    disequence h = run (h undefined) 0
+        where run [] _ = []
+              run (_ : xs) i = let f a = h a !! i
+                               in f : run xs (i+1)
+
+instance Ditraversable (->) m Any =>  Ditraversable (->) (ListT m) Any where 
+    dimapM f g = disequence (f . g)
+    disequence h = ListT $ (`run`  0) =<< runListT (h undefined)
+        where run [] _ = return []
+              run (_ : xs) i = do f <- disequence $ liftM (!! i) . runListT . h
+                                  liftM (f :) (run xs (i+1))
+
+instance (Monoid w, Ditraversable (->) m Any) => Ditraversable (->) (RWST r w s m) Any where
+    dimapM f g = disequence (f . g)
+    disequence h = RWST trans
+        where trans r s = 
+                  do (_,s',w) <- runRWST (h undefined) r s
+                     fun <-  disequence (liftM fst' . (\ m -> runRWST m r s) . h)
+                     return (fun,s',w)
+              fst' (x,_,_) = x
diff --git a/src/Data/Comp/Param/Equality.hs b/src/Data/Comp/Param/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Equality.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,
+  UndecidableInstances, IncoherentInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Equality
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines equality for signatures, which lifts to equality for
+-- terms.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.Equality
+    (
+     PEq(..),
+     EqD(..)
+    ) where
+
+import Data.Comp.Param.Term
+import Data.Comp.Param.Sum
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.FreshM
+
+-- |Equality on parametric values. The equality test is performed inside the
+-- 'FreshM' monad for generating fresh identifiers.
+class PEq a where
+    peq :: a -> a -> FreshM Bool
+
+instance Eq a => PEq a where
+    peq x y = return $ x == y
+
+{-| Signature equality. An instance @EqD f@ gives rise to an instance
+  @Eq (Term f)@. The equality test is performed inside the 'FreshM' monad for
+  generating fresh identifiers. -}
+class EqD f where
+    eqD :: PEq a => f Var a -> f Var a -> FreshM Bool
+
+{-| 'EqD' is propagated through sums. -}
+instance (EqD f, EqD g) => EqD (f :+: g) where
+    eqD (Inl x) (Inl y) = eqD x y
+    eqD (Inr x) (Inr y) = eqD x y
+    eqD _ _ = return False
+
+{-| From an 'EqD' difunctor an 'Eq' instance of the corresponding term type can
+  be derived. -}
+instance EqD f => EqD (Cxt h f) where
+    eqD (Term e1) (Term e2) = eqD e1 e2
+    eqD (Hole h1) (Hole h2) = peq h1 h2
+    eqD (Place p1) (Place p2) = peq p1 p2
+    eqD _ _ = return False
+
+instance (EqD f, PEq a) => PEq (Cxt h f Var a) where
+    peq = eqD
+
+{-| Equality on terms. -}
+instance (Difunctor f, EqD f) => Eq (Term f) where
+    (==) x y = evalFreshM $ eqD (coerceCxt x) (coerceCxt y)
diff --git a/src/Data/Comp/Param/FreshM.hs b/src/Data/Comp/Param/FreshM.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/FreshM.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.FreshM
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines a monad for generating fresh, abstract variables, useful
+-- e.g. for defining equality on terms.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.FreshM
+    (
+     FreshM,
+     Var,
+     genVar,
+     evalFreshM
+    ) where
+
+import Control.Monad.State
+
+-- |Monad for generating fresh (abstract) variables.
+newtype FreshM a = FreshM (State [String] a)
+    deriving Monad
+
+-- |Abstract notion of a variable (the constructor is hidden).
+data Var = Var String
+           deriving Eq
+
+instance Show Var where
+    show (Var x) = x
+
+instance Ord Var where
+    compare (Var x) (Var y) = compare x y
+
+-- |Generate a fresh variable.
+genVar :: FreshM Var
+genVar = FreshM $ do xs <- get
+                     case xs of
+                       (x : xs') -> do {put xs'; return $ Var x}
+                       _ -> fail "Unexpected empty list"
+
+-- |Evaluate a computation that uses fresh variables.
+evalFreshM :: FreshM a -> a
+evalFreshM (FreshM m) = evalState m vars
+    where baseVars = ['a'..'z']
+          vars = map (:[]) baseVars ++ vars' 1
+          vars' n = map (: show n) baseVars ++ vars' (n + 1)
diff --git a/src/Data/Comp/Param/Ops.hs b/src/Data/Comp/Param/Ops.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Ops.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies,
+  FlexibleInstances, UndecidableInstances, IncoherentInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Ops
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides operators on difunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Ops where
+
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Ditraversable
+import Control.Monad (liftM)
+
+
+-- Sums
+infixr 6 :+:
+
+-- |Formal sum of signatures (difunctors).
+data (f :+: g) a b = Inl (f a b)
+                   | Inr (g a b)
+
+instance (Difunctor f, Difunctor g) => Difunctor (f :+: g) where
+    dimap f g (Inl e) = Inl (dimap f g e)
+    dimap f g (Inr e) = Inr (dimap f g e)
+
+instance (Ditraversable f m a, Ditraversable g m a)
+    => Ditraversable (f :+: g) m a where
+    dimapM f (Inl e) = Inl `liftM` dimapM f e
+    dimapM f (Inr e) = Inr `liftM` dimapM f e
+    disequence (Inl e) = Inl `liftM` disequence e
+    disequence (Inr e) = Inr `liftM` disequence e
+
+-- | Signature containment relation for automatic injections. The left-hand must
+-- be an atomic signature, where as the right-hand side must have a list-like
+-- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@,
+-- non-examples include @f :+: g :<: f :+: (g :+: h)@ and
+-- @f :<: (f :+: g) :+: h@.
+class sub :<: sup where
+  inj :: sub a b -> sup a b
+  proj :: sup a b -> Maybe (sub a b)
+
+instance (:<:) f f where
+    inj = id
+    proj = Just
+
+instance (:<:) f (f :+: g) where
+    inj = Inl
+    proj (Inl x) = Just x
+    proj (Inr _) = Nothing
+
+instance (f :<: g) => (:<:) f (h :+: g) where
+    inj = Inr . inj
+    proj (Inr x) = proj x
+    proj (Inl _) = Nothing
+
+
+-- Products
+infixr 8 :*:
+
+-- |Formal product of signatures (difunctors).
+data (f :*: g) a b = f a b :*: g a b
+
+ffst :: (f :*: g) a b -> f a b
+ffst (x :*: _) = x
+
+fsnd :: (f :*: g) a b -> g a b
+fsnd (_ :*: x) = x
+
+
+-- Constant Products
+infixr 7 :&:
+
+{-| This data type adds a constant product to a signature. -}
+data (f :&: p) a b = f a b :&: p
+
+instance Difunctor f => Difunctor (f :&: p) where
+    dimap f g (v :&: c) = dimap f g v :&: c
+
+instance Ditraversable f m a => Ditraversable (f :&: p) m a where
+    dimapM f (v :&: c) = liftM (:&: c) (dimapM f v)
+    disequence (v :&: c) = liftM (:&: c) (disequence v)
+
+{-| This class defines how to distribute an annotation over a sum of
+  signatures. -}
+class DistAnn s p s' | s' -> s, s' -> p where
+    {-| Inject an annotation over a signature. -}
+    injectA :: p -> s a b -> s' a b
+    {-| Project an annotation from a signature. -}
+    projectA :: s' a b -> (s a b, p)
+
+class RemA s s' | s -> s'  where
+    {-| Remove annotations from a signature. -}
+    remA :: s a b -> s' a b
+
+instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where
+    remA (Inl (v :&: _)) = Inl v
+    remA (Inr v) = Inr $ remA v
+
+instance RemA (f :&: p) f where
+    remA (v :&: _) = v
+
+instance DistAnn f p (f :&: p) where
+    injectA c v = v :&: c
+
+    projectA (v :&: p) = (v,p)
+
+instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where
+    injectA c (Inl v) = Inl (v :&: c)
+    injectA c (Inr v) = Inr $ injectA c v
+
+    projectA (Inl (v :&: p)) = (Inl v,p)
+    projectA (Inr v) = let (v',p) = projectA v
+                       in  (Inr v',p)
diff --git a/src/Data/Comp/Param/Ordering.hs b/src/Data/Comp/Param/Ordering.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Ordering.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,
+  UndecidableInstances, IncoherentInstances, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Ordering
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines ordering of signatures, which lifts to ordering of
+-- terms and contexts.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.Ordering
+    (
+     POrd(..),
+     OrdD(..)
+    ) where
+
+import Data.Comp.Param.Term
+import Data.Comp.Param.Sum
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.FreshM
+import Data.Comp.Param.Equality
+
+-- |Ordering of parametric values.
+class PEq a => POrd a where
+    pcompare :: a -> a -> FreshM Ordering
+
+instance Ord a => POrd a where
+    pcompare x y = return $ compare x y
+
+{-| Signature ordering. An instance @OrdD f@ gives rise to an instance
+  @Ord (Term f)@. -}
+class EqD f => OrdD f where
+    compareD :: POrd a => f Var a -> f Var a -> FreshM Ordering
+
+{-| 'OrdD' is propagated through sums. -}
+instance (OrdD f, OrdD g) => OrdD (f :+: g) where
+    compareD (Inl x) (Inl y) = compareD x y
+    compareD (Inl _) (Inr _) = return LT
+    compareD (Inr x) (Inr y) = compareD x y
+    compareD (Inr _) (Inl _) = return GT
+
+{-| From an 'OrdD' difunctor an 'Ord' instance of the corresponding term type
+  can be derived. -}
+instance OrdD f => OrdD (Cxt h f) where
+    compareD (Term e1) (Term e2) = compareD e1 e2
+    compareD (Hole h1) (Hole h2) = pcompare h1 h2
+    compareD (Place p1) (Place p2) = pcompare p1 p2
+    compareD (Term _) _ = return LT
+    compareD (Hole _) (Term _) = return GT
+    compareD (Hole _) (Place _) = return LT
+    compareD (Place _) _ = return GT
+
+instance (OrdD f, POrd a) => POrd (Cxt h f Var a) where
+    pcompare = compareD
+
+{-| Ordering of terms. -}
+instance (Difunctor f, OrdD f) => Ord (Term f) where
+    compare x y = evalFreshM $ compareD (coerceCxt x) (coerceCxt y)
diff --git a/src/Data/Comp/Param/Show.hs b/src/Data/Comp/Param/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Show.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances,
+  IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Show
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines showing of signatures, which lifts to showing of terms.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Param.Show
+    (
+     PShow(..),
+     ShowD(..)
+    ) where
+
+import Data.Comp.Param.Term
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Derive
+import Data.Comp.Param.FreshM
+
+instance Show a => PShow a where
+    pshow x = return $ show x
+
+-- Lift ShowD to sums
+$(derive [liftSum] [''ShowD])
+
+{-| From an 'ShowD' difunctor an 'ShowD' instance of the corresponding term type
+  can be derived. -}
+instance ShowD f => ShowD (Cxt h f) where
+    showD (Term t) = showD t
+    showD (Hole h) = pshow h
+    showD (Place p) = pshow p
+
+instance (ShowD f, PShow a) => PShow (Cxt h f Var a) where
+    pshow = showD
+
+{-| Printing of terms. -}
+instance (Difunctor f, ShowD f) => Show (Term f) where
+    show x = evalFreshM $ showD $ coerceCxt x
+
+instance (ShowD f, PShow p) => ShowD (f :&: p) where
+    showD (x :&: p) = do sx <- showD x
+                         sp <- pshow p
+                         return $ sx ++ " :&: " ++ sp
diff --git a/src/Data/Comp/Param/Sum.hs b/src/Data/Comp/Param/Sum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Sum.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,
+  FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
+  ScopedTypeVariables, TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Sum
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides the infrastructure to extend signatures.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Sum
+    (
+     (:<:),
+     (:+:),
+
+     -- * Projections for Signatures and Terms
+     proj,
+     proj2,
+     proj3,
+     proj4,
+     proj5,
+     proj6,
+     proj7,
+     proj8,
+     proj9,
+     proj10,
+     project,
+     project2,
+     project3,
+     project4,
+     project5,
+     project6,
+     project7,
+     project8,
+     project9,
+     project10,
+     deepProject,
+     deepProject2,
+     deepProject3,
+     deepProject4,
+     deepProject5,
+     deepProject6,
+     deepProject7,
+     deepProject8,
+     deepProject9,
+     deepProject10,
+
+     -- * Injections for Signatures and Terms
+     inj,
+     inj2,
+     inj3,
+     inj4,
+     inj5,
+     inj6,
+     inj7,
+     inj8,
+     inj9,
+     inj10,
+     inject,
+     inject2,
+     inject3,
+     inject4,
+     inject5,
+     inject6,
+     inject7,
+     inject8,
+     inject9,
+     inject10,
+     deepInject,
+     deepInject2,
+     deepInject3,
+     deepInject4,
+     deepInject5,
+     deepInject6,
+     deepInject7,
+     deepInject8,
+     deepInject9,
+     deepInject10,
+
+     -- * Injections and Projections for Constants
+     injectConst,
+     injectConst2,
+     injectConst3,
+     projectConst,
+     injectCxt,
+     liftCxt
+    ) where
+
+import Prelude hiding (sequence)
+import Control.Monad hiding (sequence)
+import Data.Comp.Param.Term
+import Data.Comp.Param.Algebra
+import Data.Comp.Param.Ops
+import Data.Comp.Param.Derive.Projections
+import Data.Comp.Param.Derive.Injections
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Ditraversable
+
+$(liftM concat $ mapM projn [2..10])
+
+-- |Project the outermost layer of a term to a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.
+project :: (g :<: f) => Cxt h f a b -> Maybe (g a (Cxt h f a b))
+project (Term t) = proj t
+project (Hole _) = Nothing
+project (Place _) = Nothing
+
+$(liftM concat $ mapM projectn [2..10])
+
+-- | Tries to coerce a term/context to a term/context over a sub-signature. If
+-- the signature @g@ is compound of /n/ atomic signatures, use
+-- @deepProject@/n/ instead.
+deepProject :: (Ditraversable g Maybe Any, g :<: f) => CxtFunM Maybe f g
+{-# INLINE deepProject #-}
+deepProject = appSigFunM' proj
+
+$(liftM concat $ mapM deepProjectn [2..10])
+{-# INLINE deepProject2 #-}
+{-# INLINE deepProject3 #-}
+{-# INLINE deepProject4 #-}
+{-# INLINE deepProject5 #-}
+{-# INLINE deepProject6 #-}
+{-# INLINE deepProject7 #-}
+{-# INLINE deepProject8 #-}
+{-# INLINE deepProject9 #-}
+{-# INLINE deepProject10 #-}
+
+$(liftM concat $ mapM injn [2..10])
+
+-- |Inject a term where the outermost layer is a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.
+inject :: (g :<: f) => g a (Cxt h f a b) -> Cxt h f a b
+inject = Term . inj
+
+$(liftM concat $ mapM injectn [2..10])
+
+-- |Inject a term over a sub signature to a term over larger signature. If the
+-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/
+-- instead.
+deepInject :: (Difunctor g, g :<: f) => CxtFun g f
+{-# INLINE deepInject #-}
+deepInject = appSigFun inj
+
+$(liftM concat $ mapM deepInjectn [2..10])
+{-# INLINE deepInject2 #-}
+{-# INLINE deepInject3 #-}
+{-# INLINE deepInject4 #-}
+{-# INLINE deepInject5 #-}
+{-# INLINE deepInject6 #-}
+{-# INLINE deepInject7 #-}
+{-# INLINE deepInject8 #-}
+{-# INLINE deepInject9 #-}
+{-# INLINE deepInject10 #-}
+
+injectConst :: (Difunctor g, g :<: f) => Const g -> Cxt h f Any a
+injectConst = inject . fmap (const undefined)
+
+injectConst2 :: (Difunctor f1, Difunctor f2, Difunctor g, f1 :<: g, f2 :<: g)
+             => Const (f1 :+: f2) -> Cxt h g Any a
+injectConst2 = inject2 . fmap (const undefined)
+
+injectConst3 :: (Difunctor f1, Difunctor f2, Difunctor f3, Difunctor g,
+                 f1 :<: g, f2 :<: g, f3 :<: g)
+             => Const (f1 :+: f2 :+: f3) -> Cxt h g Any a
+injectConst3 = inject3 . fmap (const undefined)
+
+projectConst :: (Difunctor g, g :<: f) => Cxt h f Any a -> Maybe (Const g)
+projectConst = fmap (fmap (const ())) . project
+
+{-| This function injects a whole context into another context. -}
+injectCxt :: (Difunctor g, g :<: f) => Cxt h g a (Cxt h f a b) -> Cxt h f a b
+injectCxt (Term t) = inject $ fmap injectCxt t
+injectCxt (Hole x) = x
+injectCxt (Place p) = Place p
+
+{-| This function lifts the given functor to a context. -}
+liftCxt :: (Difunctor f, g :<: f) => g a b -> Cxt Hole f a b
+liftCxt g = simpCxt $ inj g
+
+instance (Show (f a b), Show (g a b)) => Show ((f :+: g) a b) where
+    show (Inl v) = show v
+    show (Inr v) = show v
+
+instance (Ord (f a b), Ord (g a b)) => Ord ((f :+: g) a b) where
+    compare (Inl _) (Inr _) = LT
+    compare (Inr _) (Inl _) = GT
+    compare (Inl x) (Inl y) = compare x y
+    compare (Inr x) (Inr y) = compare x y
+
+instance (Eq (f a b), Eq (g a b)) => Eq ((f :+: g) a b) where
+    (Inl x) == (Inl y) = x == y
+    (Inr x) == (Inr y) = x == y                   
+    _ == _ = False
diff --git a/src/Data/Comp/Param/Term.hs b/src/Data/Comp/Param/Term.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Param/Term.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes,
+  MultiParamTypeClasses #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Param.Term
+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the central notion of /parametrized terms/ and their
+-- generalisation to parametrised contexts.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Param.Term
+    (
+     Cxt(..),
+     Hole,
+     NoHole,
+     Any,
+     Term,
+     Trm,
+     Context,
+     Const,
+     simpCxt,
+     coerceCxt,
+     toCxt,
+     constTerm,
+     fmapCxt,
+     disequenceCxt,
+     dimapMCxt
+    ) where
+
+import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)
+import Data.Comp.Param.Any
+import Data.Comp.Param.Difunctor
+import Data.Comp.Param.Ditraversable
+import Control.Monad
+import Unsafe.Coerce
+
+{-| This data type represents contexts over a signature. Contexts are terms
+  containing zero or more holes, and zero or more parameters. The first
+  parameter is a phantom type indicating whether the context has holes. The
+  second paramater is the signature of the context, in the form of a
+  "Data.Comp.Param.Difunctor". The third parameter is the type of parameters,
+  and the fourth parameter is the type of holes. -}
+data Cxt :: * -> (* -> * -> *) -> * -> * -> * where
+            Term :: f a (Cxt h f a b) -> Cxt h f a b
+            Hole :: b -> Cxt Hole f a b
+            Place :: a -> Cxt h f a b
+
+{-| Phantom type used to define 'Context'. -}
+data Hole
+
+{-| Phantom type used to define 'Term'. -}
+data NoHole
+
+{-| A context may contain holes, but must be parametric in the bound
+  parameters. Parametricity is \"emulated\" using the empty type @Any@, e.g. a
+  function of type @Any -> T[Any]@ is equivalent with @forall b. b -> T[b]@,
+  but the former avoids the impredicative typing extension, and works also in
+  the cases where the codomain type is not a type constructor, e.g.
+  @Any -> (Any,Any)@. -}
+type Context = Cxt Hole
+
+type Trm f a = Cxt NoHole f a ()
+
+{-| A term is a context with no holes, where all occurrences of the
+  contravariant parameter is fully parametric. Parametricity is \"emulated\"
+  using the empty type @Any@, e.g. a function of type @Any -> T[Any]@ is
+  equivalent with @forall b. b -> T[b]@, but the former avoids the impredicative
+  typing extension, and works also in the cases where the codomain type is not a
+  type constructor, e.g. @Any -> (Any,Any)@. -}
+type Term f = Trm f Any
+
+{-| Convert a difunctorial value into a context. -}
+simpCxt :: Difunctor f => f a b -> Cxt Hole f a b
+{-# INLINE simpCxt #-}
+simpCxt = Term . fmap Hole
+
+{-| Cast a \"pseudo-parametric\" context over a signature to a parametric
+  context over the same signature. The usage of 'unsafeCoerce' is safe, because
+  the empty type 'Any' witnesses that all uses of the contravariant argument are
+  parametric. -}
+coerceCxt :: Cxt h f Any b -> forall a. Cxt h f a b
+coerceCxt = unsafeCoerce
+
+toCxt :: Difunctor f => Trm f a -> Cxt h f a b
+{-# INLINE toCxt #-}
+toCxt = unsafeCoerce
+
+{-|  -}
+type Const f = f Any ()
+
+{-| This function converts a constant to a term. This assumes that the
+  argument is indeed a constant, i.e. does not have a value for the
+  argument type of the difunctor @f@. -}
+constTerm :: Difunctor f => Const f -> Term f
+constTerm = Term . fmap (const undefined)
+
+-- | This is an instance of 'fmap' for 'Cxt'.
+fmapCxt :: Difunctor f => (b -> b') -> Cxt h f a b -> Cxt h f a b'
+fmapCxt f = run
+    where run (Term t) = Term $ fmap run t
+          run (Place a) = Place a
+          run (Hole b)  = Hole $ f b
+
+-- | This is an instance of 'dimamM' for 'Cxt'.
+dimapMCxt :: Ditraversable f m a => (b -> m b') -> Cxt h f a b -> m (Cxt h f a b')
+dimapMCxt f = run
+              where run (Term t)  = liftM Term $ dimapM run t
+                    run (Place a) = return $ Place a
+                    run (Hole b)  = liftM Hole (f b)
+
+-- | This is an instance of 'disequence' for 'Cxt'.
+disequenceCxt :: Ditraversable f m a => Cxt h f a (m b) -> m (Cxt h f a b)
+disequenceCxt (Term t)  = liftM Term $ dimapM disequenceCxt t
+disequenceCxt (Place a) = return $ Place a
+disequenceCxt (Hole b)  = liftM Hole b
diff --git a/src/Data/Comp/Product.hs b/src/Data/Comp/Product.hs
deleted file mode 100644
--- a/src/Data/Comp/Product.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,
-  UndecidableInstances, RankNTypes, GADTs #-}
---------------------------------------------------------------------------------
--- |
--- Module      :  Data.Comp.Product
--- Copyright   :  (c) 2010-2011 Patrick Bahr
--- License     :  BSD3
--- Maintainer  :  Patrick Bahr <paba@diku.dk>
--- Stability   :  experimental
--- Portability :  non-portable (GHC Extensions)
---
--- This module defines products on signatures.
---
---------------------------------------------------------------------------------
-
-module Data.Comp.Product
-    ( (:&:) (..),
-      (:*:) (..),
-      DistProd (..),
-      RemoveP (..),
-      liftP,
-      liftP',
-      stripP,
-      productTermHom,
-      constP,
-      project'
-    )where
-
-import Data.Comp.Term
-import Data.Comp.Sum
-import Data.Comp.Ops
-import Data.Comp.Algebra
-
-import Control.Monad
-
-
-
-{-| Transform a function with a domain constructed from a functor to a function
- with a domain constructed with the same functor, but with an additional
- product. -}
-
-liftP :: (RemoveP s s') => (s' a -> t) -> s a -> t
-liftP f v = f (removeP v)
-
-
-{-| Transform a function with a domain constructed from a functor to a function
-  with a domain constructed with the same functor, but with an additional
-  product. -}
-liftP' :: (DistProd s' p s, Functor s, Functor s')
-       => (s' a -> Cxt h s' a) -> s a -> Cxt h s a
-liftP' f v = let (v',p) = projectP v
-             in constP p (f v')
-    
-{-| Strip the products from a term over a functor with products. -}
-stripP :: (Functor f, RemoveP g f, Functor g) => Cxt h g a -> Cxt h f a
-stripP = appSigFun removeP
-
-{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism
- over the same signatures, but extended with products. -}
-productTermHom :: (DistProd f p f', DistProd g p g', Functor g, Functor g') 
-            => TermHom f g -> TermHom f' g'
-productTermHom alg f' = constP p (alg f)
-    where (f,p) = projectP f'
-
-{-| Annotate each node of a term with a constant value. -}
-constP :: (DistProd f p g, Functor f, Functor g) 
-       => p -> Cxt h f a -> Cxt h g a
-constP c = appSigFun (injectP c)
-
-{-| This function is similar to 'project' but applies to signatures
-with a product which is then ignored. -}
--- bug in type checker? below is the inferred type, however, the type checker
--- rejects it.
--- project' :: (RemoveP f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))
-project' v = liftM removeP $ project v
diff --git a/src/Data/Comp/Show.hs b/src/Data/Comp/Show.hs
--- a/src/Data/Comp/Show.hs
+++ b/src/Data/Comp/Show.hs
@@ -18,8 +18,7 @@
     ) where
 
 import Data.Comp.Term
-import Data.Comp.Sum
-import Data.Comp.Product
+import Data.Comp.Annotation
 import Data.Comp.Algebra
 import Data.Comp.Derive
 
@@ -33,8 +32,5 @@
 instance (ShowF f, Show p) => ShowF (f :&: p) where
     showF (v :&: p) = showF v ++ " :&: " ++ show p
 
-instance (ShowF f, ShowF g) => ShowF (f :+: g) where
-    showF (Inl f) = showF f
-    showF (Inr g) = showF g
-
-$(derive [instanceShowF] [''Maybe, ''[], ''(,)])
+$(derive [liftSum] [''ShowF])
+$(derive [makeShowF] [''Maybe, ''[], ''(,)])
diff --git a/src/Data/Comp/Sum.hs b/src/Data/Comp/Sum.hs
--- a/src/Data/Comp/Sum.hs
+++ b/src/Data/Comp/Sum.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,
-             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
-             ScopedTypeVariables #-}
-
+  FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
+  ScopedTypeVariables, TemplateHaskell #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Sum
@@ -17,31 +16,72 @@
 
 module Data.Comp.Sum
     (
-     (:<:)(..),
-     (:+:)(..),
+     (:<:),
+     (:+:),
 
      -- * Projections for Signatures and Terms
+     proj,
      proj2,
      proj3,
+     proj4,
+     proj5,
+     proj6,
+     proj7,
+     proj8,
+     proj9,
+     proj10,
      project,
      project2,
      project3,
+     project4,
+     project5,
+     project6,
+     project7,
+     project8,
+     project9,
+     project10,
      deepProject,
      deepProject2,
      deepProject3,
-     deepProject',
-     deepProject2',
-     deepProject3',
+     deepProject4,
+     deepProject5,
+     deepProject6,
+     deepProject7,
+     deepProject8,
+     deepProject9,
+     deepProject10,
 
      -- * Injections for Signatures and Terms
+     inj,
      inj2,
      inj3,
+     inj4,
+     inj5,
+     inj6,
+     inj7,
+     inj8,
+     inj9,
+     inj10,
      inject,
      inject2,
      inject3,
+     inject4,
+     inject5,
+     inject6,
+     inject7,
+     inject8,
+     inject9,
+     inject10,
      deepInject,
      deepInject2,
      deepInject3,
+     deepInject4,
+     deepInject5,
+     deepInject6,
+     deepInject7,
+     deepInject8,
+     deepInject9,
+     deepInject10,
 
      -- * Injections and Projections for Constants
      injectConst,
@@ -57,128 +97,72 @@
 import Data.Comp.Term
 import Data.Comp.Algebra
 import Data.Comp.Ops
-
-import Control.Monad hiding (sequence)
-import Prelude hiding (sequence)
+import Data.Comp.Derive.Projections
+import Data.Comp.Derive.Injections
 
+import Control.Monad hiding (mapM,sequence)
+import Prelude hiding (mapM,sequence)
 
 import Data.Maybe
 import Data.Traversable
 import Data.Map (Map)
 import qualified Data.Map as Map
 
-{-| A variant of 'proj' for binary sum signatures.  -}
-proj2 :: forall f g1 g2 a. (g1 :<: f, g2 :<: f) => f a -> Maybe ((g1 :+: g2) a)
-proj2 x = case proj x of
-            Just (y :: g1 a) -> Just $ inj y
-            _ -> liftM inj (proj x :: Maybe (g2 a))
 
-{-| A variant of 'proj' for ternary sum signatures.  -}
-proj3 :: forall f g1 g2 g3 a. (g1 :<: f, g2 :<: f, g3 :<: f) => f a
-      -> Maybe ((g1 :+: g2 :+: g3) a)
-proj3 x = case proj x of
-            Just (y :: g1 a) -> Just $ inj y
-            _ -> case proj x of
-                   Just (y :: g2 a) -> Just $ inj y
-                   _ -> liftM inj (proj x :: Maybe (g3 a))
+$(liftM concat $ mapM projn [2..10])
 
--- |Project the outermost layer of a term to a sub signature.
+-- |Project the outermost layer of a term to a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.
 project :: (g :<: f) => Cxt h f a -> Maybe (g (Cxt h f a))
 project (Hole _) = Nothing
 project (Term t) = proj t
 
--- |Project the outermost layer of a term to a binary sub signature.
-project2 :: (g1 :<: f, g2 :<: f) => Cxt h f a -> Maybe ((g1 :+: g2) (Cxt h f a))
-project2 (Hole _) = Nothing
-project2 (Term t) = proj2 t
-
--- |Project the outermost layer of a term to a ternary sub signature.
-project3 :: (g1 :<: f, g2 :<: f, g3 :<: f) => Cxt h f a
-         -> Maybe ((g1 :+: g2 :+: g3) (Cxt h f a))
-project3 (Hole _) = Nothing
-project3 (Term t) = proj3 t
-
--- |Project a term to a term over a sub signature.
-deepProject :: (Traversable f, Functor g, g :<: f) => Cxt h f a
-            -> Maybe (Cxt h g a)
-deepProject = appSigFunM proj
-
--- |Project a term to a term over a binary sub signature.
-deepProject2 :: (Traversable f, Functor g1, Functor g2, g1 :<: f, g2 :<: f) => Cxt h f a -> Maybe (Cxt h (g1 :+: g2) a)
-deepProject2 = appSigFunM proj2
-
--- |Project a term to a term over a ternary sub signature.
-deepProject3 :: (Traversable f, Functor g1, Functor g2, Functor g3,
-                 g1 :<: f, g2 :<: f, g3 :<: f) => Cxt h f a
-             -> Maybe (Cxt h (g1 :+: g2 :+: g3) a)
-deepProject3 = appSigFunM proj3
-
--- |A variant of 'deepProject' where the sub signature is required to be
--- 'Traversable' rather than the whole signature.
-deepProject' :: forall g f h a. (Traversable g, g :<: f) => Cxt h f a
-             -> Maybe (Cxt h g a)
-deepProject' val = do
-  v <- project val
-  v' <- sequence (fmap deepProject' v :: g (Maybe (Cxt h g a)))
-  return $ Term v'
-
--- |A variant of 'deepProject2' where the sub signatures are required to be
--- 'Traversable' rather than the whole signature.
-deepProject2' :: forall g1 g2 f h a. (Traversable g1, Traversable g2,
-                                      g1 :<: f, g2 :<: f) => Cxt h f a
-             -> Maybe (Cxt h (g1 :+: g2) a)
-deepProject2' val = do
-  v <- project2 val
-  v' <- sequence (fmap deepProject2' v :: (g1 :+: g2) (Maybe (Cxt h (g1 :+: g2) a)))
-  return $ Term v'
+$(liftM concat $ mapM projectn [2..10])
 
--- |A variant of 'deepProject3' where the sub signatures are required to be
--- 'Traversable' rather than the whole signature.
-deepProject3' :: forall g1 g2 g3 f h a. (Traversable g1, Traversable g2,
-                                         Traversable g3, g1 :<: f, g2 :<: f,
-                                         g3 :<: f) => Cxt h f a
-             -> Maybe (Cxt h (g1 :+: g2 :+: g3) a)
-deepProject3' val = do
-  v <- project3 val
-  v' <- sequence (fmap deepProject3' v :: (g1 :+: g2 :+: g3) (Maybe (Cxt h (g1 :+: g2 :+: g3) a)))
-  return $ Term v'
+-- | Tries to coerce a term/context to a term/context over a sub-signature. If
+-- the signature @g@ is compound of /n/ atomic signatures, use
+-- @deepProject@/n/ instead.
+deepProject :: (Traversable g, g :<: f) => CxtFunM Maybe f g
+{-# INLINE deepProject #-}
+deepProject = appSigFunM' proj
 
-{-| A variant of 'inj' for binary sum signatures.  -}
-inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a -> g a
-inj2 (Inl x) = inj x
-inj2 (Inr y) = inj y
+$(liftM concat $ mapM deepProjectn [2..10])
+{-# INLINE deepProject2 #-}
+{-# INLINE deepProject3 #-}
+{-# INLINE deepProject4 #-}
+{-# INLINE deepProject5 #-}
+{-# INLINE deepProject6 #-}
+{-# INLINE deepProject7 #-}
+{-# INLINE deepProject8 #-}
+{-# INLINE deepProject9 #-}
+{-# INLINE deepProject10 #-}
 
-{-| A variant of 'inj' for ternary sum signatures.  -}
-inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a -> g a
-inj3 (Inl x) = inj x
-inj3 (Inr y) = inj2 y
+$(liftM concat $ mapM injn [2..10])
 
--- |Inject a term where the outermost layer is a sub signature.
+-- |Inject a term where the outermost layer is a sub signature. If the signature
+-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.
 inject :: (g :<: f) => g (Cxt h f a) -> Cxt h f a
 inject = Term . inj
 
--- |Inject a term where the outermost layer is a binary sub signature.
-inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) (Cxt h g a) -> Cxt h g a
-inject2 = Term . inj2
-
--- |Inject a term where the outermost layer is a ternary sub signature.
-inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) (Cxt h g a) -> Cxt h g a
-inject3 = Term . inj3
+$(liftM concat $ mapM injectn [2..10])
 
--- |Inject a term over a sub signature to a term over larger signature.
-deepInject  :: (Functor g, Functor f, g :<: f) => Cxt h g a -> Cxt h f a
+-- |Inject a term over a sub signature to a term over larger signature. If the
+-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/
+-- instead.
+deepInject :: (Functor g, g :<: f) => CxtFun g f
+{-# INLINE deepInject #-}
 deepInject = appSigFun inj
 
--- |Inject a term over a binary sub signature to a term over larger signature.
-deepInject2 :: (Functor f1, Functor f2, Functor g, f1 :<: g, f2 :<: g)
-            => Cxt h (f1 :+: f2) a -> Cxt h g a
-deepInject2 = appSigFun inj2
-
--- |Inject a term over a ternary signature to a term over larger signature.
-deepInject3 :: (Functor f1, Functor f2, Functor f3, Functor g,
-                f1 :<: g, f2 :<: g, f3 :<: g)
-            => Cxt h (f1 :+: f2 :+: f3) a -> Cxt h g a
-deepInject3 =  appSigFun inj3
+$(liftM concat $ mapM deepInjectn [2..10])
+{-# INLINE deepInject2 #-}
+{-# INLINE deepInject3 #-}
+{-# INLINE deepInject4 #-}
+{-# INLINE deepInject5 #-}
+{-# INLINE deepInject6 #-}
+{-# INLINE deepInject7 #-}
+{-# INLINE deepInject8 #-}
+{-# INLINE deepInject9 #-}
+{-# INLINE deepInject10 #-}
 
 injectConst :: (Functor g, g :<: f) => Const g -> Cxt h f a
 injectConst = inject . fmap (const undefined)
@@ -195,7 +179,6 @@
 projectConst = fmap (fmap (const ())) . project
 
 {-| This function injects a whole context into another context. -}
-
 injectCxt :: (Functor g, g :<: f) => Cxt h' g (Cxt h f a) -> Cxt h f a
 injectCxt = cata' inject
 
diff --git a/src/Data/Comp/Term.hs b/src/Data/Comp/Term.hs
--- a/src/Data/Comp/Term.hs
+++ b/src/Data/Comp/Term.hs
@@ -102,33 +102,37 @@
 type PTerm f = forall h a . Cxt h f a
 
 instance Functor f => Functor (Cxt h f) where
-    fmap f (Hole v) = Hole (f v)
-    fmap f (Term t) = Term (fmap (fmap f) t)
+    fmap f = run
+        where run (Hole v) = Hole (f v)
+              run (Term t) = Term (fmap run t)
 
 instance (Foldable f) => Foldable (Cxt h f) where
-    foldr op e (Hole a) = a `op` e
-    foldr op e (Term t) = foldr op' e t
-        where op' c a = foldr op a c
+    foldr op c a = run a c
+        where run (Hole a) e = a `op` e
+              run (Term t) e = foldr run e t
 
-    foldl op e (Hole a) = e `op` a
-    foldl op e (Term t) = foldl op' e t
-        where op' = foldl op
+    foldl op = run
+        where run e (Hole a) = e `op` a
+              run e (Term t) = foldl run e t
 
     fold (Hole a) = a
     fold (Term t) = foldMap fold t
 
-    foldMap f (Hole a) = f a
-    foldMap f (Term t) = foldMap (foldMap f) t
+    foldMap f = run
+        where run (Hole a) = f a
+              run (Term t) = foldMap run t
 
 instance (Traversable f) => Traversable (Cxt h f) where
-    traverse f (Hole a) = Hole <$> f a
-    traverse f (Term t) = Term <$> traverse (traverse f) t
+    traverse f = run
+        where run (Hole a) = Hole <$> f a
+              run (Term t) = Term <$> traverse run t
                           
     sequenceA (Hole a) = Hole <$> a
     sequenceA (Term t) = Term <$> traverse sequenceA t
 
-    mapM f (Hole a) = liftM Hole $ f a
-    mapM f (Term t) = liftM Term $ mapM (mapM f) t
+    mapM f = run 
+        where run (Hole a) = liftM Hole $ f a
+              run (Term t) = liftM Term $ mapM run t
 
     sequence (Hole a) = liftM Hole a
     sequence (Term t) = liftM Term $ mapM sequence t
diff --git a/src/Data/Comp/Variables.hs b/src/Data/Comp/Variables.hs
--- a/src/Data/Comp/Variables.hs
+++ b/src/Data/Comp/Variables.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,
-  OverlappingInstances, TypeOperators #-}
+  OverlappingInstances, TypeOperators, TemplateHaskell #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Variables
@@ -10,7 +10,8 @@
 -- Portability :  non-portable (GHC Extensions)
 --
 -- This module defines an abstract notion of (bound) variables in compositional
--- data types, and capture-avoiding substitution.
+-- data types, and scoped substitution. Capture-avoidance is /not/ taken into
+-- account.
 --
 --------------------------------------------------------------------------------
 module Data.Comp.Variables
@@ -29,8 +30,8 @@
     ) where
 
 import Data.Comp.Term
-import Data.Comp.Sum
 import Data.Comp.Algebra
+import Data.Comp.Derive
 import Data.Foldable hiding (elem, notElem)
 import Data.Maybe
 import Data.Set (Set)
@@ -54,11 +55,7 @@
     bindsVars :: f a -> [v]
     bindsVars _ = []
 
-instance (HasVars f v, HasVars g v) => HasVars (f :+: g) v where
-    isVar (Inl v) = isVar v
-    isVar (Inr v) = isVar v
-    bindsVars (Inl v) = bindsVars v
-    bindsVars (Inr v) = bindsVars v
+$(derive [liftSum] [''HasVars])
 
 instance HasVars f v => HasVars (Cxt h f) v where
     isVar (Term t) = isVar t
@@ -74,7 +71,7 @@
               let vars' = vars ++ bindsVars t in
               case isVar t of
                 Just v ->
-                    -- Check for capture-avoidance
+                    -- Check for scope
                     if v `elem` vars' then
                         Term $ fmap (\x -> x vars') t
                     else
@@ -145,7 +142,7 @@
             where substAlg :: (HasVars f v) => (v -> Maybe (Cxt h f a))
                            -> Alg f (Cxt h f a)
                   substAlg f t = fromMaybe (Term t) (isVar t >>= f)
-                  res :: Eq v => [v] -> (v -> Maybe t) -> (v -> Maybe t)
+                  res :: Eq v => [v] -> (v -> Maybe t) -> v -> Maybe t
                   res vars f x = if x `elem` vars then Nothing else f x
 
 instance (SubstVars v t a, Functor f) => SubstVars v t (f a) where
diff --git a/testsuite/tests/Data/Comp/Examples/Comp.hs b/testsuite/tests/Data/Comp/Examples/Comp.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp/Examples/Comp.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Comp.Examples.Comp where
+
+import qualified Examples.Eval as Eval
+import qualified Examples.EvalM as EvalM
+import qualified Examples.DesugarEval as DesugarEval
+import qualified Examples.DesugarPos as DesugarPos
+
+import Data.Comp
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+tests = testGroup "Compositional Data Types" [
+         testProperty "eval" evalTest,
+         testProperty "evalM" evalMTest,
+         testProperty "desugarEval" desugarEvalTest,
+         testProperty "desugarPos" desugarPosTest
+        ]
+
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+instance (EqF f, Eq p) => EqF (f :&: p) where
+    eqF (v1 :&: p1) (v2 :&: p2) = p1 == p2 && v1 `eqF` v2
+
+evalTest = Eval.evalEx == Eval.iConst 5
+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 5)
+desugarEvalTest = DesugarEval.evalEx == DesugarEval.iPair (DesugarEval.iConst 2) (DesugarEval.iConst 1)
+desugarPosTest = DesugarPos.desugPEx ==
+                 DesugarPos.iAPair
+                               (DesugarPos.Pos 1 0)
+                               (DesugarPos.iASnd
+                                              (DesugarPos.Pos 1 0)
+                                              (DesugarPos.iAPair
+                                                             (DesugarPos.Pos 1 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))
+                               (DesugarPos.iAFst
+                                              (DesugarPos.Pos 1 0)
+                                              (DesugarPos.iAPair
+                                                             (DesugarPos.Pos 1 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))
diff --git a/testsuite/tests/Data/Comp/Examples/Multi.hs b/testsuite/tests/Data/Comp/Examples/Multi.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp/Examples/Multi.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Comp.Examples.Multi where
+
+import qualified Examples.Multi.Eval as Eval
+import qualified Examples.Multi.EvalI as EvalI
+import qualified Examples.Multi.EvalM as EvalM
+import qualified Examples.Multi.DesugarEval as DesugarEval
+import qualified Examples.Multi.DesugarPos as DesugarPos
+
+import Data.Comp.Multi
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+tests = testGroup "Generalised Compositional Data Types" [
+         testProperty "eval" evalTest,
+         testProperty "evalI" evalITest,
+         testProperty "evalM" evalMTest,
+         testProperty "desugarEval" desugarEvalTest,
+         testProperty "desugarPos" desugarPosTest
+        ]
+
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+instance (HEqF f, Eq p) => HEqF (f :&: p) where
+    heqF (v1 :&: p1) (v2 :&: p2) = p1 == p2 && v1 `heqF` v2
+
+evalTest = Eval.evalEx == Eval.iConst 2
+evalITest = EvalI.evalIEx == 2
+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 5)
+desugarEvalTest = DesugarEval.evalEx == DesugarEval.iPair (DesugarEval.iConst 2) (DesugarEval.iConst 1)
+desugarPosTest = DesugarPos.desugPEx ==
+                 DesugarPos.iAPair
+                               (DesugarPos.Pos 1 0)
+                               (DesugarPos.iASnd
+                                              (DesugarPos.Pos 1 0)
+                                              (DesugarPos.iAPair
+                                                             (DesugarPos.Pos 1 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))
+                               (DesugarPos.iAFst
+                                              (DesugarPos.Pos 1 0)
+                                              (DesugarPos.iAPair
+                                                             (DesugarPos.Pos 1 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)
+                                                             (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))
diff --git a/testsuite/tests/Data/Comp/Examples/MultiParam.hs b/testsuite/tests/Data/Comp/Examples/MultiParam.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp/Examples/MultiParam.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Comp.Examples.MultiParam where
+
+import qualified Examples.MultiParam.Eval as Eval
+import qualified Examples.MultiParam.EvalI as EvalI
+import qualified Examples.MultiParam.EvalM as EvalM
+import qualified Examples.MultiParam.EvalAlgM as EvalAlgM
+import qualified Examples.MultiParam.DesugarEval as DesugarEval
+import qualified Examples.MultiParam.DesugarPos as DesugarPos
+
+import Data.Comp.MultiParam
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+tests = testGroup "Parametric Compositional Data Types" [
+         testProperty "eval" evalTest,
+         testProperty "evalI" evalITest,
+         testProperty "evalM" evalMTest,
+         testProperty "evalAlgM" evalAlgMTest,
+         testProperty "desugarEval" desugarEvalTest,
+         testProperty "desugarPos" desugarPosTest
+        ]
+
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+instance (EqHD f, Eq p) => EqHD (f :&: p) where
+    eqHD (v1 :&: p1) (v2 :&: p2) = do b <- eqHD v1 v2
+                                      return $ p1 == p2 && b
+
+evalTest = Eval.evalEx == Just (Eval.iConst 4)
+evalITest = EvalI.evalEx == 4
+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 12)
+evalAlgMTest = EvalAlgM.evalMEx == Just (EvalAlgM.iConst 5)
+desugarEvalTest = DesugarEval.evalEx == Just (DesugarEval.iConst (-6))
+desugarPosTest = DesugarPos.desugPEx ==
+                 DesugarPos.iAApp (DesugarPos.Pos 1 0)
+                                  (DesugarPos.iALam (DesugarPos.Pos 1 0) $ \x -> DesugarPos.iAMult (DesugarPos.Pos 1 2) (DesugarPos.iAConst (DesugarPos.Pos 1 2) (-1)) (Place x))
+                                  (DesugarPos.iAConst (DesugarPos.Pos 1 1) 6)
diff --git a/testsuite/tests/Data/Comp/Examples/Param.hs b/testsuite/tests/Data/Comp/Examples/Param.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp/Examples/Param.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Comp.Examples.Param where
+
+import qualified Examples.Param.Eval as Eval
+import qualified Examples.Param.EvalM as EvalM
+import qualified Examples.Param.EvalAlgM as EvalAlgM
+import qualified Examples.Param.DesugarEval as DesugarEval
+import qualified Examples.Param.DesugarPos as DesugarPos
+import qualified Examples.Param.Parsing as Parsing
+
+import Data.Comp.Param
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+tests = testGroup "Parametric Compositional Data Types" [
+         testProperty "eval" evalTest,
+         testProperty "evalM" evalMTest,
+         testProperty "evalAlgM" evalAlgMTest,
+         testProperty "desugarEval" desugarEvalTest,
+         testProperty "desugarPos" desugarPosTest,
+         testProperty "parsing" parsingTest
+        ]
+
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+instance (EqD f, PEq p) => EqD (f :&: p) where
+    eqD (v1 :&: p1) (v2 :&: p2) = do b1 <- peq p1 p2
+                                     b2 <- eqD v1 v2
+                                     return $ b1 && b2
+
+evalTest = Eval.evalEx == Just (Eval.iConst 4)
+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 12)
+evalAlgMTest = EvalAlgM.evalMEx == Just (EvalAlgM.iConst 5)
+desugarEvalTest = DesugarEval.evalEx == Just (DesugarEval.iConst 720)
+desugarPosTest = DesugarPos.desugPEx ==
+                 DesugarPos.iAApp (DesugarPos.Pos 1 0)
+                                  (DesugarPos.iALam (DesugarPos.Pos 1 0) Place)
+                                  (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \f ->
+                                       DesugarPos.iAApp (DesugarPos.Pos 1 1)
+                                                        (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \x ->
+                                                             DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place f) (DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place x) (Place x)))
+                                                        (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \x ->
+                                                             DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place f) (DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place x) (Place x))))
+parsingTest = Parsing.transEx == (Parsing.iLam $ \a -> Parsing.iApp (Parsing.iLam $ \b -> Parsing.iLam $ \c -> Place b) (Place a))
diff --git a/testsuite/tests/Data/Comp/Examples_Test.hs b/testsuite/tests/Data/Comp/Examples_Test.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp/Examples_Test.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeOperators #-}
+module Data.Comp.Examples_Test where
+
+import qualified Data.Comp.Examples.Comp as C
+import qualified Data.Comp.Examples.Multi as M
+import qualified Data.Comp.Examples.Param as P
+import qualified Data.Comp.Examples.MultiParam as MP
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+tests = testGroup "Examples" [
+         C.tests,
+         M.tests,
+         P.tests,
+         MP.tests
+       ]
diff --git a/testsuite/tests/Data/Comp_Test.hs b/testsuite/tests/Data/Comp_Test.hs
--- a/testsuite/tests/Data/Comp_Test.hs
+++ b/testsuite/tests/Data/Comp_Test.hs
@@ -12,7 +12,7 @@
 import Test.Utils
 
 import qualified Data.Comp.Equality_Test
-
+import qualified Data.Comp.Examples_Test
 
 --------------------------------------------------------------------------------
 -- Test Suits
@@ -21,7 +21,8 @@
 main = defaultMain [tests]
 
 tests = testGroup "Comp" [
-         Data.Comp.Equality_Test.tests
+         Data.Comp.Equality_Test.tests,
+         Data.Comp.Examples_Test.tests
         ]
 
 --------------------------------------------------------------------------------
diff --git a/testsuite/tests/Test/Utils.hs b/testsuite/tests/Test/Utils.hs
--- a/testsuite/tests/Test/Utils.hs
+++ b/testsuite/tests/Test/Utils.hs
@@ -16,7 +16,7 @@
 data Pair a e = Pair a e
 
 $(derive
-  [instanceFunctor, instanceFoldable, instanceShowF, instanceEqF, instanceArbitraryF]
+  [makeFunctor, makeFoldable, makeShowF, makeEqF, makeArbitraryF]
   [''Tree, ''Pair])
 
 $(derive