diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,36 @@
+import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.PackageDescription
+import System.Cmd
+import System.FilePath
+import System.Directory
+import Control.Exception
+import System.IO.Error (isDoesNotExistError)
+
+
+main = defaultMainWithHooks hooks
+  where hooks = simpleUserHooks { runTests = runTests'}
+
+
+hpcReportDir = "hpcreport"
+
+runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()
+runTests' _ _ _ lbi = do
+  res <- try (removeFile tixFile)
+  case res of
+    Left err
+        | not (isDoesNotExistError err) -> putStrLn "tix file could not be removed"
+    _ -> return ()
+  putStrLn "running tests ..."
+  system testprog
+  putStrLn "computing code coverage ..."
+  hpcReport
+  putStrLn "generating code coverage reports ..."
+  hpcMarkup
+  return ()
+    where testprog = (buildDir lbi) </> "test" </> "test"
+          tixFile = "test.tix"
+          hpcReport = system $ "hpc report test"++exclArgs
+          hpcMarkup = system $ "hpc markup test --destdir="++hpcReportDir++exclArgs
+          excludedModules = []
+          exclArgs = concatMap (" --exclude="++) excludedModules
diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Benchmark.hs
@@ -0,0 +1,129 @@
+module Main where
+
+import Criterion.Main
+import qualified Functions.Comp as A
+import qualified Functions.Standard as S
+import DataTypes.Comp as DC
+import DataTypes.Standard as DS
+import DataTypes.Transform
+import Data.Comp
+import Data.Comp.DeepSeq ()
+import Control.DeepSeq
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen
+import System.Random
+
+aExpr :: SugarExpr
+aExpr = iIf ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))
+            `iOr` ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))))
+       ((iVInt 2 `iMinus` iVInt 1))
+       (iVInt 3)
+
+sExpr :: PExpr
+sExpr = transSugar aExpr
+
+aHOASExpr :: Int -> DC.HOASExpr
+aHOASExpr n = (iLam $ \x -> x `iPlus` ((iLam $ \x -> x `iMult` x) `iApp` x))
+              `iApp`
+              ((iLam $ \x -> x `iMult` x)
+               `iApp`
+               (if n <= 0 then iVInt 2 else aHOASExpr (n - 1)))
+
+sHOASExpr :: Int -> DS.HOASExpr
+sHOASExpr = transHOAS . aHOASExpr
+
+sfCoalg :: Coalg SugarSig Int
+sfCoalg 0 = inj $ VInt 1
+sfCoalg n = let n' = n-1 in inj $ Plus n' n'
+
+sfGen' :: Int -> SugarExpr
+sfGen'  = ana' sfCoalg
+
+sfGen :: Int -> SugarExpr
+sfGen  = ana sfCoalg
+
+shortcutFusion :: Benchmark
+shortcutFusion = bgroup "shortcut-fusion" [
+                  bench "eval without fusion" (nf (A.evalSugar2 . sfGen) depth),
+                  bench "eval with fusion" (nf (A.evalSugar2 . sfGen') depth)
+                  ]
+    where depth = 15
+
+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.desugar" (nf A.desugarExpr aExpr),
+                 bench "Comp.desugarAlg" (nf A.desugarExpr2 aExpr),
+                 bench "Standard.desugar" (nf S.desugar sExpr),
+                 bench "Comp.desugarType" (nf A.desugarType aExpr),
+                 bench "Comp.desugarType'" (nf A.desugarType' aExpr),
+                 bench "Standard.desugarType" (nf S.desugarType sExpr),
+                 bench "Comp.typeSugar" (nf A.typeSugar aExpr),
+                 bench "Standard.typeSugar" (nf S.typeSugar sExpr),
+                 bench "Comp.desugarType2" (nf A.desugarType2 aExpr),
+                 bench "Comp.desugarType2'" (nf A.desugarType2' aExpr),
+                 bench "Standard.desugarType2" (nf S.desugarType2 sExpr),
+                 bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),
+                 bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),
+                 bench "Comp.desugarEval" (nf A.desugarEval aExpr),
+                 bench "Comp.desugarEval'" (nf A.desugarEval' aExpr),
+                 bench "Standard.desugarEval" (nf S.desugarEval sExpr),
+                 bench "Comp.evalSugar" (nf A.evalSugar aExpr),
+                 bench "Comp.evalDirect" (nf A.evalDirectE aExpr),
+                 bench "Standard.evalSugar" (nf S.evalSugar sExpr),
+                 bench "Comp.desugarEval2" (nf A.desugarEval2 aExpr),
+                 bench "Comp.desugarEval2'" (nf A.desugarEval2' aExpr),
+                 bench "Standard.desugarEval2" (nf S.desugarEval2 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
+randStdBenchmarks s = do
+  rand <- getStdGen
+  let ty = unGen arbitrary rand s
+  putStr "size of the type term: "
+  print $ size ty
+  print $ ty
+  let aExpr = unGen (genTyped ty) rand s
+      sExpr = transSugar aExpr
+  putStr "size of the input term: "
+  print $ size aExpr
+  putStr "does it type check: "
+  print (A.desugarType aExpr == Right ty)
+  return $ standardBenchmarks (sExpr,aExpr, "random (depth: " ++ show s ++ ", size: "++ show (size aExpr) ++ ")")
+
+hoasBenchmaks :: Int -> Benchmark
+hoasBenchmaks s = bgroup ("HOAS (depth: " ++ show s ++ ")") $ getBench s
+    where getBench size =
+              let sExpr' = sHOASExpr size
+                  aExpr' = aHOASExpr size in
+              rnf aExpr' `seq` rnf sExpr' `seq`
+              [bench "Comp.eval2E" 
+                     (nf (A.eval2E :: DC.HOASExpr -> HOASValueExpr) aExpr'),
+               bench "Standard.evalHOAS" (nf S.evalHOAS sExpr')]
+
+main = do b1 <- randStdBenchmarks 5
+          b2 <- randStdBenchmarks 10
+          b3 <- randStdBenchmarks 20
+          let b0 = standardBenchmarks (sExpr, aExpr, "hand-written")
+          let b4 = map hoasBenchmaks [1,10,100,1000,10000]
+          defaultMain $ [b0,b1,b2,b3] ++ b4
+
+          
+
+{-
+TODO 
+ - benchmark generic functions (e.g. size, depth, breadth)
+
+-}
diff --git a/benchmark/DataTypes.hs b/benchmark/DataTypes.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/DataTypes.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeSynonymInstances, CPP #-}
+
+module DataTypes where
+
+type Err = Either String
+
+#if __GLASGOW_HASKELL__ < 700
+instance Monad Err where
+    return = Right
+    e >>= f = case e of 
+                Left m -> Left m
+                Right x -> f x
+    fail  = Left
+#endif
diff --git a/benchmark/DataTypes/Comp.hs b/benchmark/DataTypes/Comp.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/DataTypes/Comp.hs
@@ -0,0 +1,190 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances #-}
+
+module DataTypes.Comp 
+    ( module DataTypes.Comp,
+      module DataTypes 
+    ) where
+
+import DataTypes
+import Data.Comp.Derive
+import Data.Comp
+import Data.Comp.Arbitrary ()
+import Data.Comp.Show
+import Data.Traversable
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen
+
+import Control.Monad hiding (sequence_,mapM)
+import Prelude hiding (sequence_,mapM)
+
+-- base values
+
+type ValueSig = Value
+type ValueExpr = Term ValueSig
+type ExprSig = Value :+:Op
+type Expr = Term ExprSig
+type SugarSig = Value :+: Op :+: Sugar
+type SugarExpr = Term SugarSig
+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
+                deriving (Eq)
+
+data Value e = VInt Int
+             | VBool Bool
+             | VPair e e
+               deriving (Eq)
+
+data Proj = ProjLeft | ProjRight
+            deriving (Eq)
+
+data Op e = Plus e e
+          | Mult e e
+          | If e e e
+          | Eq e e
+          | Lt e e
+          | And e e
+          | Not e
+          | Proj Proj e
+            deriving (Eq)
+
+data Sugar e = Neg e
+             | Minus e e
+             | Gt e e
+             | Or e e
+             | Impl e e
+               deriving (Eq)
+
+data FunT e = TFun e e
+              deriving (Eq)
+
+data Lam e = Lam (e -> e)
+
+data App e = App e e
+             deriving (Eq)
+
+$(derive [instanceNFData, instanceArbitrary] [''Proj])
+
+$(derive
+  [instanceFunctor, instanceExpFunctor, instanceFoldable, instanceTraversable,
+   instanceEqF, instanceNFDataF, instanceArbitraryF, smartConstructors]
+  [''Value, ''Op, ''Sugar, ''ValueT, ''FunT, ''App])
+
+$(derive [instanceExpFunctor, smartConstructors] [''Lam])
+
+instance EqF Lam where
+    eqF _ _ = False
+
+instance NFDataF Lam where
+    rnfF (Lam f) = f `seq` ()
+
+showBinOp :: String -> String -> String -> String
+showBinOp op x y = "("++ x ++ op ++ y ++ ")"
+
+instance ShowF Value where
+    showF (VInt i) = show i
+    showF (VBool b) = show b
+    showF (VPair x y) = showBinOp "," x y
+
+
+instance ShowF Op where
+    showF (Plus x y) = showBinOp "+" x y
+    showF (Mult x y) = showBinOp "*" x y
+    showF (If b x y) = "if " ++ b ++ " then " ++ x ++ " else " ++ y ++ " fi"
+    showF (Eq x y) = showBinOp "==" x y
+    showF (Lt x y) = showBinOp "<" x y
+    showF (And x y) = showBinOp "&&" x y
+    showF (Not x) = "~" ++ x
+    showF (Proj ProjLeft x) = x ++ "!0"
+    showF (Proj ProjRight x) = x ++ "!1"
+
+instance ShowF ValueT where 
+    showF TInt = "Int"
+    showF TBool = "Bool"
+    showF (TPair 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
+    genTypedAlg a = do dist <- genTypedAlg' a
+                       frequency $ map (\ (i,f) -> (i,return f)) dist
+    genTypedAlg' :: BaseType -> Gen [(Int,f BaseType)]
+    genTypedAlg' a = genTypedAlg a >>= \ g -> return [(1,g)]
+
+genTyped :: forall f . (Traversable f, GenTyped f) => BaseType -> Gen (Term f)
+genTyped = run 
+    where run :: BaseType -> Gen (Term f)
+          run t = liftM Term $ genTypedAlg t >>= mapM (desize . run)
+
+desize :: Gen a -> Gen a
+desize gen = sized (\n -> resize (max 0 (n-1)) gen)
+
+genSomeTyped :: (Traversable f, GenTyped f) => Gen (Term f)
+genSomeTyped = arbitrary >>= genTyped 
+
+
+instance (GenTyped f, GenTyped g) => GenTyped (f :+: g) where
+    genTypedAlg' t = do 
+      left <- genTypedAlg' t
+      right <- genTypedAlg' t
+      let left' = map inl left
+          right' = map inr right
+      return (left' ++ right')
+        where inl (i,gen) = (i,Inl gen)
+              inr (i,gen) = (i,Inr gen)
+
+instance GenTyped Value where
+    genTypedAlg' (Term t) = run t
+        where run TInt  = arbitrary >>= \i-> return [(1,VInt i)]
+              run TBool = arbitrary >>= \b-> return [(1,VBool b)]
+              run (TPair s t) = return [(1, VPair s t)]
+
+instance GenTyped Op where
+    genTypedAlg' ty = sized run
+        where run n = do (ty1,ty2) <- arbitrary
+                         other' <- other n
+                         return $ other' ++ [(n,If iTBool ty ty),
+                                   (n,Proj ProjLeft (iTPair ty ty1)),
+                                   (n,Proj ProjRight (iTPair ty2 ty))]
+              other n = case unTerm ty of
+                        TInt -> return [(n,Plus iTInt iTInt),(n,Plus iTInt iTInt)]
+                        TBool -> arbitrary >>= \t -> return
+                                 [(n, Eq t t),
+                                  (n,Lt iTInt iTInt),
+                                  (n,And iTBool iTBool),
+                                  (n,Not iTBool)]
+                        TPair _ _ -> return []
+
+instance GenTyped Sugar where
+    genTypedAlg' (Term t) = sized (run t)
+        where run TInt n = return [(5*n,Neg iTInt),(5*n,Minus iTInt iTInt)]
+              run TBool n = return [(5*n,Gt iTInt iTInt),(5*n,Or iTBool iTBool),
+                                 (5*n,Impl iTBool iTBool)]
+              run TPair{} _ = return []
diff --git a/benchmark/DataTypes/Standard.hs b/benchmark/DataTypes/Standard.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/DataTypes/Standard.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable #-}
+module DataTypes.Standard 
+    ( module DataTypes.Standard,
+      module DataTypes 
+    ) where
+
+import DataTypes
+import Data.Derive.NFData
+import Data.DeriveTH
+import Data.Data
+import Control.DeepSeq
+
+-- base values
+
+data VType = VTInt
+           | VTBool
+           | VTPair VType VType
+             deriving (Eq,Typeable,Data)
+
+data SExpr = SInt Int
+           | SBool Bool
+           | SPair SExpr SExpr
+             deriving (Eq,Typeable,Data)
+
+data SProj = SProjLeft | SProjRight
+             deriving (Eq,Typeable,Data)
+
+data OExpr = OInt Int
+           | OBool Bool
+           | OPair OExpr OExpr
+           | OPlus OExpr OExpr
+           | OMult OExpr OExpr
+           | OIf OExpr OExpr OExpr
+           | OEq OExpr OExpr
+           | OLt OExpr OExpr
+           | OAnd OExpr OExpr
+           | ONot OExpr
+           | OProj SProj OExpr
+             deriving (Eq,Typeable,Data)
+
+data PExpr = PInt Int
+           | PBool Bool
+           | PPair PExpr PExpr
+           | PPlus PExpr PExpr
+           | PMult PExpr PExpr
+           | PIf PExpr PExpr PExpr
+           | PEq PExpr PExpr
+           | PLt PExpr PExpr
+           | PAnd PExpr PExpr
+           | PNot PExpr
+           | PProj SProj PExpr
+           | PNeg PExpr
+           | PMinus PExpr PExpr
+           | PGt PExpr PExpr
+           | POr PExpr PExpr
+           | PImpl PExpr PExpr
+             deriving (Eq,Typeable,Data)
+
+data VHType = VHTInt
+            | VHTBool
+            | VHTPair VType VType
+            | 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 ++ ")"
+
+instance Show SExpr where
+    show (SInt i) = show i
+    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
+    show (OPair x y) = showBinOp "," (show x) (show y)
+    show (OPlus x y) = showBinOp "+" (show x) (show y)
+    show (OMult x y) = showBinOp "*" (show x) (show y)
+    show (OIf b x y) = "if " ++ show b ++ " then " ++ show x ++ " else " ++ show y ++ " fi"
+    show (OEq x y) = showBinOp "==" (show x) (show y)
+    show (OLt x y) = showBinOp "<" (show x) (show y)
+    show (OAnd x y) = showBinOp "&&" (show x) (show y)
+    show (ONot x) = "~" ++ (show x)
+    show (OProj SProjLeft x) = (show x) ++ "!0"
+    show (OProj SProjRight x) = (show x) ++ "!1"
+
+instance Show VType where 
+    show VTInt = "Int"
+    show VTBool = "Bool"
+    show (VTPair x y) = "(" ++ show x ++ "," ++ show y ++ ")"
+
+$(derives [makeNFData] [''SProj,''SExpr,''OExpr,''PExpr,''VType])
diff --git a/benchmark/DataTypes/Transform.hs b/benchmark/DataTypes/Transform.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/DataTypes/Transform.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances #-}
+
+module DataTypes.Transform where
+
+import Data.Comp
+import Data.Comp.ExpFunctor
+import DataTypes.Standard as S
+import DataTypes.Comp
+
+class TransSugar f where
+    transSugarAlg :: Alg f PExpr
+
+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
+
+instance TransSugar Value where
+    transSugarAlg (VInt i) = PInt i
+    transSugarAlg (VBool b) = PBool b
+    transSugarAlg (VPair x y) = PPair x y
+
+instance TransSugar Op where
+    transSugarAlg (Plus x y) = PPlus x y
+    transSugarAlg (Mult x y) = PMult x y
+    transSugarAlg (If b x y) = PIf b x y
+    transSugarAlg (Lt x y) = PLt x y
+    transSugarAlg (And x y) = PAnd x y
+    transSugarAlg (Not x) = PNot x
+    transSugarAlg (Proj p x) = PProj (ptrans p) x
+        where ptrans ProjLeft = SProjLeft
+              ptrans ProjRight = SProjRight
+    transSugarAlg (Eq x y) = PEq x y
+
+instance TransSugar Sugar where
+    transSugarAlg (Neg x) = PNeg x
+    transSugarAlg (Minus x y) = PMinus x y
+    transSugarAlg (Gt x y) = PGt x y
+    transSugarAlg (Or x y) = POr x y
+    transSugarAlg (Impl x y) = PImpl x y
+
+class TransHOAS f where
+    transHOASAlg :: Alg f S.HOASExpr
+
+transHOAS :: (ExpFunctor f, TransHOAS f) => Term f -> S.HOASExpr
+transHOAS = cataE transHOASAlg
+
+instance (TransHOAS f, TransHOAS g) => TransHOAS (f :+: g) where
+    transHOASAlg (Inl v) = transHOASAlg v
+    transHOASAlg (Inr v) = transHOASAlg v
+
+instance TransHOAS Value where
+    transHOASAlg (VInt i) = HOASInt i
+    transHOASAlg (VBool b) = HOASBool b
+    transHOASAlg (VPair x y) = HOASPair x y
+
+instance TransHOAS Op where
+    transHOASAlg (Plus x y) = HOASPlus x y
+    transHOASAlg (Mult x y) = HOASMult x y
+    transHOASAlg (If b x y) = HOASIf b x y
+    transHOASAlg (Lt x y) = HOASLt x y
+    transHOASAlg (And x y) = HOASAnd x y
+    transHOASAlg (Not x) = HOASNot x
+    transHOASAlg (Proj p x) = HOASProj (ptrans p) x
+        where ptrans ProjLeft = SProjLeft
+              ptrans ProjRight = SProjRight
+    transHOASAlg (Eq x y) = HOASEq x y
+
+instance TransHOAS Lam where
+    transHOASAlg (Lam f) = HOASLam $ f . HOASVal
+
+instance TransHOAS App where
+    transHOASAlg (App x y) = HOASApp x y
diff --git a/benchmark/Functions.hs b/benchmark/Functions.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions.hs
@@ -0,0 +1,5 @@
+module Functions 
+    ( module Functions.Comp,
+      module Functions.Standard ) where
+import Functions.Comp
+import Functions.Standard
diff --git a/benchmark/Functions/Comp.hs b/benchmark/Functions/Comp.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Comp.hs
@@ -0,0 +1,9 @@
+module Functions.Comp
+    ( module Functions.Comp.Desugar,
+      module Functions.Comp.Eval,
+      module Functions.Comp.Inference,
+      module Functions.Comp.FreeVars ) where
+import Functions.Comp.Desugar
+import Functions.Comp.Eval
+import Functions.Comp.Inference
+import Functions.Comp.FreeVars
diff --git a/benchmark/Functions/Comp/Desugar.hs b/benchmark/Functions/Comp/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Comp/Desugar.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances #-}
+
+module Functions.Comp.Desugar where
+
+import DataTypes.Comp
+import Data.Comp
+import Data.Traversable
+
+-- de-sugar
+
+class (Functor e, Traversable f) => Desugar f e where
+    desugarAlg :: TermHom f e
+
+desugarExpr :: SugarExpr -> Expr
+desugarExpr = desugar
+
+desugar :: Desugar f e => Term f -> Term e
+{-# INLINE desugar #-}
+desugar = appTermHom desugarAlg
+
+instance (Desugar f e, Desugar g e) => Desugar (g :+: f) e where
+    desugarAlg (Inl v) = desugarAlg v
+    desugarAlg (Inr v) = desugarAlg v
+
+instance (Value :<: v, Functor v) => Desugar Value v where
+    desugarAlg = liftCxt
+
+instance (Op :<: v, Functor v) => Desugar Op v where
+    desugarAlg = liftCxt
+
+instance (Op :<: v, Value :<: v, Functor v) => Desugar Sugar v where
+    desugarAlg (Neg x) =  iVInt (-1) `iMult` (Hole x)
+    desugarAlg (Minus x y) =  (Hole x) `iPlus` ((iVInt (-1)) `iMult` (Hole y))
+    desugarAlg (Gt x y) =  (Hole y) `iLt` (Hole x)
+    desugarAlg (Or x y) = iNot (iNot (Hole x) `iAnd` iNot (Hole y))
+    desugarAlg (Impl x y) = iNot ((Hole x) `iAnd` iNot (Hole y))
+
+
+-- standard algebraic approach
+
+class Desugar2 f g where
+    desugarAlg2 :: Alg f (Term g)
+
+desugarExpr2 :: SugarExpr -> Expr
+desugarExpr2 = desugar2
+
+desugar2 :: (Functor f, Desugar2 f g) => Term f -> Term g
+desugar2 = cata desugarAlg2
+
+instance (Desugar2 f e, Desugar2 g e) => Desugar2 (f :+: g) e where
+    desugarAlg2 (Inl v) = desugarAlg2 v
+    desugarAlg2 (Inr v) = desugarAlg2 v
+
+instance (Value :<: v) => Desugar2 Value v where
+    desugarAlg2 = inject
+
+instance (Op :<: v) => Desugar2 Op v where
+    desugarAlg2 = inject
+
+instance (Op :<: v, Value :<: v, Functor v) => Desugar2 Sugar v where
+    desugarAlg2 (Neg x) =  iVInt (-1) `iMult` x
+    desugarAlg2 (Minus x y) =  x `iPlus` ((iVInt (-1)) `iMult` y)
+    desugarAlg2 (Gt x y) =  y `iLt` x
+    desugarAlg2 (Or x y) = iNot (iNot x `iAnd` iNot y)
+    desugarAlg2 (Impl x y) = iNot (x `iAnd` iNot y)
+
diff --git a/benchmark/Functions/Comp/Eval.hs b/benchmark/Functions/Comp/Eval.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Comp/Eval.hs
@@ -0,0 +1,298 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances #-}
+
+module Functions.Comp.Eval where
+
+import DataTypes.Comp
+import Functions.Comp.Desugar
+import Data.Comp
+import Data.Comp.ExpFunctor
+import Control.Monad
+import Data.Traversable
+
+-- evaluation
+
+class Monad m => Eval e v m where
+    evalAlg :: e (Term v) -> m (Term v)
+
+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
+
+instance (Value :<: v, Monad m) => Eval Value v m where
+    evalAlg = return . inject
+
+coerceInt :: (Value :<: v, Monad m) => Term v -> m Int
+coerceInt t = case project t of
+                Just (VInt i) -> return i
+                _ -> fail ""
+
+coerceBool :: (Value :<: v, Monad m) => Term v -> m Bool
+coerceBool t = case project t of
+                Just (VBool b) -> return b
+                _ -> fail ""
+
+coercePair :: (Value :<: v, Monad m) => Term v -> m (Term v, Term v)
+coercePair t = case project t of
+                Just (VPair x y) -> return (x,y)
+                _ -> fail ""
+
+instance (Value :<: v, EqF v, Monad m) => Eval Op v m where
+    evalAlg (Plus x y) = liftM2 (\ i j -> iVInt (i + j)) (coerceInt x) (coerceInt y)
+    evalAlg (Mult x y) = liftM2 (\ i j -> iVInt (i * j)) (coerceInt x) (coerceInt y)
+    evalAlg (If b x y) = liftM select (coerceBool b)
+        where select b' = if b' then x else y
+    evalAlg (Eq x y) = return $ iVBool (x == y)
+    evalAlg (Lt x y) = liftM2 (\ i j -> iVBool (i < j)) (coerceInt x) (coerceInt y)
+    evalAlg (And x y) = liftM2 (\ b c -> iVBool (b && c)) (coerceBool x) (coerceBool y)
+    evalAlg (Not x) = liftM (iVBool . not) (coerceBool x)
+    evalAlg (Proj p x) = liftM select (coercePair x)
+        where select (x,y) = case p of 
+                               ProjLeft -> x
+                               ProjRight -> y
+
+instance (Value :<: v, Monad m) => Eval Sugar v m where
+    evalAlg (Neg x) = liftM (iVInt . negate) (coerceInt x)
+    evalAlg (Minus x y) = liftM2 (\ i j -> iVInt (i - j)) (coerceInt x) (coerceInt y)
+    evalAlg (Gt x y) = liftM2 (\ i j -> iVBool (i > j)) (coerceInt x) (coerceInt y)
+    evalAlg (Or x y) = liftM2 (\ b c -> iVBool (b || c)) (coerceBool x) (coerceBool y)
+    evalAlg (Impl x y) = liftM2 (\ b c -> iVBool (not b || c)) (coerceBool x) (coerceBool y)
+
+
+-- direct evaluation
+
+class Monad m => EvalDir e m where
+    evalDir :: (Traversable f, EvalDir f m) => e (Term f) -> m ValueExpr
+
+evalDirect :: (Traversable e, EvalDir e m) => Term e -> m ValueExpr
+evalDirect = evalDir . unTerm
+
+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
+
+instance (Monad m) => EvalDir Value m where
+    evalDir (VInt i) = return $ iVInt i
+    evalDir (VBool i) = return $ iVBool i
+    evalDir (VPair x y) = liftM2 iVPair (evalDirect x) (evalDirect y)
+
+
+evalInt :: (Traversable e, EvalDir e m) => Term e -> m Int
+evalInt t = do
+  t' <- evalDirect t
+  case project t' of
+    Just (VInt i) -> return i
+    _ -> fail ""
+
+evalBool :: (Traversable e, EvalDir e m) => Term e -> m Bool
+evalBool t = do
+  t' <- evalDirect t
+  case project t' of
+    Just (VBool b) -> return b
+    _ -> fail ""
+
+evalPair :: (Traversable e, EvalDir e m) => Term e -> m (ValueExpr, ValueExpr)
+evalPair t = do
+  t' <- evalDirect t
+  case project t' of
+    Just (VPair x y) -> return (x,y)
+    _ -> fail ""
+
+instance (Monad m) => EvalDir Op m where
+    evalDir (Plus x y) = liftM2 (\ i j -> iVInt (i + j)) (evalInt x) (evalInt y)
+    evalDir (Mult x y) = liftM2 (\ i j -> iVInt (i * j)) (evalInt x) (evalInt y)
+    evalDir (If b x y) = do 
+      b' <- evalBool b
+      if b' then evalDirect x else evalDirect y
+    evalDir (Eq x y) = liftM iVBool $ liftM2 (==) (evalDirect x) (evalDirect y)
+    evalDir (Lt x y) = liftM2 (\ i j -> iVBool (i < j)) (evalInt x) (evalInt y)
+    evalDir (And x y) = liftM2 (\ b c -> iVBool (b && c)) (evalBool x) (evalBool y)
+    evalDir (Not x) = liftM (iVBool . not) (evalBool x)
+    evalDir (Proj p x) = liftM select (evalPair x)
+        where select (x,y) = case p of 
+                               ProjLeft -> x
+                               ProjRight -> y
+
+instance (Monad m) => EvalDir Sugar m where
+    evalDir (Neg x) = liftM (iVInt . negate) (evalInt x)
+    evalDir (Minus x y) = liftM2 (\ i j -> iVInt (i - j)) (evalInt x) (evalInt y)
+    evalDir (Gt x y) = liftM2 (\ i j -> iVBool (i > j)) (evalInt x) (evalInt y)
+    evalDir (Or x y) = liftM2 (\ b c -> iVBool (b || c)) (evalBool x) (evalBool y)
+    evalDir (Impl x y) = liftM2 (\ b c -> iVBool (not b || c)) (evalBool x) (evalBool y)
+
+
+-- evaluation2
+
+class ExpFunctor e => Eval2 e v where
+    eval2Alg :: e (Term v) -> Term v
+
+eval2 :: (Functor e, Eval2 e v) => Term e -> Term v
+eval2 = cata eval2Alg
+
+eval2E :: (ExpFunctor e, Eval2 e v) => Term e -> Term v
+eval2E = cataE eval2Alg
+
+instance (Eval2 f v, Eval2 g v) => Eval2 (f :+: g) v where
+    eval2Alg (Inl v) = eval2Alg v
+    eval2Alg (Inr v) = eval2Alg v
+
+instance (Value :<: v) => Eval2 Value v where
+    eval2Alg = inject
+
+coerceInt2 :: (Value :<: v) => Term v -> Int
+coerceInt2 t = case project t of
+                Just (VInt i) -> i
+                _ -> undefined
+
+coerceBool2 :: (Value :<: v) => Term v -> Bool
+coerceBool2 t = case project t of
+                Just (VBool b) -> b
+                _ -> undefined
+
+coercePair2 :: (Value :<: v) => Term v -> (Term v, Term v)
+coercePair2 t = case project t of
+                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)
+    eval2Alg (If b x y) = select (coerceBool2 b)
+        where select b' = if b' then x else y
+    eval2Alg (Eq x y) = iVBool (x == y)
+    eval2Alg (Lt x y) = (\ i j -> iVBool (i < j)) (coerceInt2 x) (coerceInt2 y)
+    eval2Alg (And x y) = (\ b c -> iVBool (b && c)) (coerceBool2 x) (coerceBool2 y)
+    eval2Alg (Not x) = (iVBool . not) (coerceBool2 x)
+    eval2Alg (Proj p x) = select (coercePair2 x)
+        where select (x,y) = case p of 
+                               ProjLeft -> x
+                               ProjRight -> y
+
+
+instance (Value :<: v) => Eval2 Sugar v where
+    eval2Alg (Neg x) = (iVInt . negate) (coerceInt2 x)
+    eval2Alg (Minus x y) = (\ i j -> iVInt (i - j)) (coerceInt2 x) (coerceInt2 y)
+    eval2Alg (Gt x y) = (\ i j -> iVBool (i > j)) (coerceInt2 x) (coerceInt2 y)
+    eval2Alg (Or x y) = (\ b c -> iVBool (b || c)) (coerceBool2 x) (coerceBool2 y)
+    eval2Alg (Impl x y) = (\ b c -> iVBool (not b || c)) (coerceBool2 x) (coerceBool2 y)
+
+instance (Lam :<: v) => Eval2 Lam v where
+    eval2Alg = inject
+
+instance (Lam :<: v) => Eval2 App v where
+    eval2Alg (App v1 v2) = (coerceLam2 v1) v2
+
+
+-- direct evaluation 2
+
+class EvalDir2 e where
+    evalDir2 :: (EvalDir2 f) => e (Term f) -> ValueExpr
+
+evalDirect2 :: (EvalDir2 e) => Term e -> ValueExpr
+evalDirect2 = evalDir2 . unTerm
+
+evalDirectE2 :: SugarExpr -> ValueExpr
+evalDirectE2 = evalDirect2
+
+instance (EvalDir2 f, EvalDir2 g) => EvalDir2 (f :+: g) where
+    evalDir2 (Inl v) = evalDir2 v
+    evalDir2 (Inr v) = evalDir2 v
+
+instance EvalDir2 Value where
+    evalDir2 (VInt i) = iVInt i
+    evalDir2 (VBool i) =  iVBool i
+    evalDir2 (VPair x y) = iVPair (evalDirect2 x) (evalDirect2 y)
+
+
+evalInt2 :: (EvalDir2 e) => Term e -> Int
+evalInt2 t = case project (evalDirect2 t) of
+               Just (VInt i) -> i
+               _ -> error ""
+
+evalBool2 :: (EvalDir2 e) => Term e -> Bool
+evalBool2 t = case project (evalDirect2 t) of
+                Just (VBool b) -> b
+                _ -> error ""
+
+evalPair2 :: (EvalDir2 e) => Term e -> (ValueExpr, ValueExpr)
+evalPair2 t = case project (evalDirect2 t) of
+               Just (VPair x y) -> (x,y)
+               _ -> error ""
+
+instance EvalDir2 Op where
+    evalDir2 (Plus x y) = (\ i j -> iVInt (i + j)) (evalInt2 x) (evalInt2 y)
+    evalDir2 (Mult x y) = (\ i j -> iVInt (i * j)) (evalInt2 x) (evalInt2 y)
+    evalDir2 (If b x y) = if evalBool2 b then evalDirect2 x else evalDirect2 y
+    evalDir2 (Eq x y) = iVBool $ (==) (evalDirect2 x) (evalDirect2 y)
+    evalDir2 (Lt x y) = (\ i j -> iVBool (i < j)) (evalInt2 x) (evalInt2 y)
+    evalDir2 (And x y) = (\ b c -> iVBool (b && c)) (evalBool2 x) (evalBool2 y)
+    evalDir2 (Not x) =  (iVBool . not) (evalBool2 x)
+    evalDir2 (Proj p x) =  select (evalPair2 x)
+        where select (x,y) = case p of 
+                               ProjLeft -> x
+                               ProjRight -> y
+
+instance EvalDir2 Sugar where
+    evalDir2 (Neg x) = (iVInt . negate) (evalInt2 x)
+    evalDir2 (Minus x y) = (\ i j -> iVInt (i - j)) (evalInt2 x) (evalInt2 y)
+    evalDir2 (Gt x y) = (\ i j -> iVBool (i > j)) (evalInt2 x) (evalInt2 y)
+    evalDir2 (Or x y) = (\ b c -> iVBool (b || c)) (evalBool2 x) (evalBool2 y)
+    evalDir2 (Impl x y) = (\ b c -> iVBool (not b || c)) (evalBool2 x) (evalBool2 y)
+
+-- desugar
+
+desugarEval :: SugarExpr -> Err ValueExpr
+desugarEval = eval . (desugar :: SugarExpr -> Expr)
+
+
+evalSugar :: SugarExpr -> Err ValueExpr
+evalSugar = eval
+
+desugarEvalAlg  :: AlgM Err SugarSig ValueExpr
+desugarEvalAlg = evalAlg  `compAlgM'` (desugarAlg :: TermHom SugarSig ExprSig)
+
+
+desugarEval' :: SugarExpr -> Err ValueExpr
+desugarEval' = cataM desugarEvalAlg
+
+desugarEval2 :: SugarExpr -> ValueExpr
+desugarEval2 = eval2 . (desugar :: SugarExpr -> Expr)
+
+desugarEval2E :: SugarExpr -> ValueExpr
+desugarEval2E = eval2E . (desugar :: SugarExpr -> Expr)
+
+
+evalSugar2 :: SugarExpr -> ValueExpr
+evalSugar2 = eval2
+
+evalSugar2E :: SugarExpr -> ValueExpr
+evalSugar2E = eval2E
+
+
+desugarEval2Alg  :: Alg SugarSig ValueExpr
+desugarEval2Alg = eval2Alg  `compAlg` (desugarAlg :: TermHom SugarSig ExprSig)
+
+
+desugarEval2' :: SugarExpr -> ValueExpr
+desugarEval2' = cata desugarEval2Alg
+
+desugarEval2E' :: SugarExpr -> ValueExpr
+desugarEval2E' = cataE desugarEval2Alg
diff --git a/benchmark/Functions/Comp/FreeVars.hs b/benchmark/Functions/Comp/FreeVars.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Comp/FreeVars.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances #-}
+
+module Functions.Comp.FreeVars where
+
+import DataTypes.Comp
+import Data.Comp.Variables
+import Data.Comp.Sum
+import Data.Comp
+import qualified Data.Foldable as F
+
+-- we interpret integers as variables here
+
+
+instance HasVars Value Int where
+    isVar (VInt i) = Just i
+    isVar _ = Nothing
+
+instance HasVars Op Int where
+
+instance HasVars Sugar Int where
+
+contVar :: Int -> SugarExpr -> Bool
+contVar = containsVar
+
+
+freeVars :: SugarExpr -> [Int]
+freeVars = variableList
+
+contVar' :: Int -> SugarExpr -> Bool
+contVar' i = cata alg
+    where alg :: SugarSig Bool -> Bool
+          alg x = case proj x of
+                    Just (VInt j) -> i == j
+                    _ -> F.foldl (||) False x
+
+contVarGen :: Int -> SugarExpr -> Bool
+contVarGen i e = elem i [ j | VInt j <- subterms' e]
+
+freeVars' :: SugarExpr -> [Int]
+freeVars' = cata alg
+    where alg :: SugarSig [Int] -> [Int]
+          alg x = case proj x of
+                    Just (VInt j) -> [ j ]
+                    _ -> F.foldl (++) [] x
+
+
+freeVarsGen :: SugarExpr -> [Int]
+freeVarsGen e =  [ j | VInt j <- subterms' e]
diff --git a/benchmark/Functions/Comp/Inference.hs b/benchmark/Functions/Comp/Inference.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Comp/Inference.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances #-}
+
+module Functions.Comp.Inference where
+
+import Functions.Comp.Desugar
+import DataTypes.Comp
+import Data.Comp
+import Data.Traversable
+
+-- type inference
+
+class Monad m => InferType f t m where
+    inferTypeAlg :: f (Term t) -> m (Term t)
+
+inferType :: (Traversable f, InferType f t m) => Term f -> m (Term t)
+inferType = cataM inferTypeAlg
+
+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
+
+instance (ValueT :<: t, Monad m) => InferType Value t m where
+    inferTypeAlg (VInt _) = return $ inject TInt
+    inferTypeAlg (VBool _) = return $ inject TBool
+    inferTypeAlg (VPair x y) = return $ inject $ TPair x y
+
+check:: (g :<: f, Eq (g (Term f)), Monad m) =>
+        g (Term f) -> Term f -> m ()
+check f t = if project t == Just f then return () else fail ""
+
+checkEq :: (Eq a, Monad m) => a -> a -> m ()
+checkEq x y = if x == y then return () else fail ""
+
+checkOp :: (g :<: f, Eq (g (Term f)), Monad m) =>
+           [g (Term f)] -> g (Term f) -> [Term f] -> m (Term f)
+checkOp exs ret tys = sequence_ (zipWith check exs tys) >> return $ inject ret
+
+
+instance (ValueT :<: t, EqF t, Monad m) => InferType Op t m where
+    inferTypeAlg (Plus x y) = checkOp [TInt,TInt] TInt [x ,y]
+    inferTypeAlg (Mult x y) = checkOp [TInt,TInt] TInt [x ,y]
+    inferTypeAlg (Lt x y) = checkOp [TInt,TInt] TBool [x ,y]
+    inferTypeAlg (And x y) = checkOp [TBool,TBool] TBool [x ,y]
+    inferTypeAlg (Not x) = checkOp [TBool] TBool [x]
+    inferTypeAlg (If b x y) = check TBool b >> checkEq x y >> return x
+    inferTypeAlg (Eq x y) = checkEq x y >> return $ iTBool
+    inferTypeAlg (Proj p x) = case project x of
+                                Just (TPair x1 x2) -> return $
+                                    case p of
+                                      ProjLeft -> x1
+                                      ProjRight -> x2
+                                _ -> fail ""
+
+instance (ValueT :<: t, EqF t, Monad m) => InferType Sugar t m where
+    inferTypeAlg (Minus x y) = checkOp [TInt,TInt] TInt [x ,y]
+    inferTypeAlg (Neg x) = checkOp [TInt] TInt [x]
+    inferTypeAlg (Gt x y) = checkOp [TInt,TInt] TBool [x ,y]
+    inferTypeAlg (Or x y) = checkOp [TBool,TBool] TBool [x ,y]
+    inferTypeAlg (Impl x y) = checkOp [TBool,TBool] TBool [x ,y]
+
+desugarType :: SugarExpr -> Err BaseType
+desugarType = inferType . (desugar :: SugarExpr -> Expr)
+
+typeSugar :: SugarExpr -> Err BaseType
+typeSugar = inferType
+
+desugarTypeAlg  :: AlgM Err SugarSig BaseType
+desugarTypeAlg = inferTypeAlg  `compAlgM'` (desugarAlg :: TermHom SugarSig ExprSig)
+
+desugarType' :: SugarExpr -> Err BaseType
+desugarType' e = cataM desugarTypeAlg e
+
+-- pure type inference
+
+class InferType2 f t where
+    inferTypeAlg2 :: f (Term t) -> (Term t)
+
+inferType2 :: (Functor f, InferType2 f t) => Term f -> (Term t)
+inferType2 = cata inferTypeAlg2
+
+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
+
+instance (ValueT :<: t) => InferType2 Value t where
+    inferTypeAlg2 (VInt _) = inject TInt
+    inferTypeAlg2 (VBool _) = inject TBool
+    inferTypeAlg2 (VPair x y) = inject $ TPair x y
+
+check2:: (g :<: f, Eq (g (Term f))) =>
+        g (Term f) -> Term f -> a -> a
+check2 f t z = if project t == Just f then z else error ""
+
+checkEq2 :: (Eq a) => a -> a -> b -> b
+checkEq2 x y z = if x == y then z else error ""
+
+runCheck :: [a -> a] -> a -> a
+runCheck = foldr (.) id
+
+checkOp2 :: (g :<: f, Eq (g (Term f))) =>
+           [g (Term f)] -> g (Term f) -> [Term f] -> (Term f)
+checkOp2 exs ret tys = runCheck (zipWith check2 exs tys) (inject ret)
+
+
+instance (ValueT :<: t, EqF t) => InferType2 Op t where
+    inferTypeAlg2 (Plus x y) = checkOp2 [TInt,TInt] TInt [x ,y]
+    inferTypeAlg2 (Mult x y) = checkOp2 [TInt,TInt] TInt [x ,y]
+    inferTypeAlg2 (Lt x y) = checkOp2 [TInt,TInt] TBool [x ,y]
+    inferTypeAlg2 (And x y) = checkOp2 [TBool,TBool] TBool [x ,y]
+    inferTypeAlg2 (Not x) = checkOp2 [TBool] TBool [x]
+    inferTypeAlg2 (If b x y) = checkEq2 x y $ check2 TBool b $ x
+    inferTypeAlg2 (Eq x y) = checkEq2 x y $ iTBool
+    inferTypeAlg2 (Proj p x) = case project x of
+                                Just (TPair x1 x2) -> 
+                                    case p of
+                                      ProjLeft -> x1
+                                      ProjRight -> x2
+                                _ -> error ""
+
+instance (ValueT :<: t, EqF t) => InferType2 Sugar t where
+    inferTypeAlg2 (Minus x y) = checkOp2 [TInt,TInt] TInt [x ,y]
+    inferTypeAlg2 (Neg x) = checkOp2 [TInt] TInt [x]
+    inferTypeAlg2 (Gt x y) = checkOp2 [TInt,TInt] TBool [x ,y]
+    inferTypeAlg2 (Or x y) = checkOp2 [TBool,TBool] TBool [x ,y]
+    inferTypeAlg2 (Impl x y) = checkOp2 [TBool,TBool] TBool [x ,y]
+
+desugarType2 :: SugarExpr -> BaseType
+desugarType2 = inferType2 . (desugar :: SugarExpr -> Expr)
+
+typeSugar2 :: SugarExpr -> BaseType
+typeSugar2 = inferType2
+
+desugarTypeAlg2  :: Alg SugarSig BaseType
+desugarTypeAlg2 = inferTypeAlg2  `compAlg` (desugarAlg :: TermHom SugarSig ExprSig)
+
+desugarType2' :: SugarExpr -> Err BaseType
+desugarType2' e = cataM desugarTypeAlg e
diff --git a/benchmark/Functions/Standard.hs b/benchmark/Functions/Standard.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Standard.hs
@@ -0,0 +1,9 @@
+module Functions.Standard
+    ( module Functions.Standard.Desugar,
+      module Functions.Standard.Eval,
+      module Functions.Standard.Inference,
+      module Functions.Standard.FreeVars) where
+import Functions.Standard.Desugar
+import Functions.Standard.Eval
+import Functions.Standard.Inference
+import Functions.Standard.FreeVars
diff --git a/benchmark/Functions/Standard/Desugar.hs b/benchmark/Functions/Standard/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Standard/Desugar.hs
@@ -0,0 +1,23 @@
+module Functions.Standard.Desugar where
+
+import DataTypes.Standard
+
+-- de-sugar
+
+desugar :: PExpr -> OExpr
+desugar (PInt i) = OInt i
+desugar (PBool b) = OBool b
+desugar (PPair x y) = OPair (desugar x) (desugar y)
+desugar (PPlus x y) = OPlus (desugar x) (desugar y)
+desugar (PMult x y) = OMult (desugar x) (desugar y)
+desugar (PIf b x y) = OIf (desugar b) (desugar x) (desugar y)
+desugar (PEq x y) = OEq (desugar x) (desugar y)
+desugar (PLt x y) = OLt (desugar x) (desugar y)
+desugar (PAnd x y) = OAnd (desugar x) (desugar y)
+desugar (PNot x) = ONot (desugar x)
+desugar (PProj p x) = OProj p (desugar x)
+desugar (PNeg x) = OInt (-1) `OMult` (desugar x)
+desugar (PMinus x y) = (desugar x) `OPlus` ((OInt (-1)) `OMult` (desugar y))
+desugar (PGt x y) = (desugar y) `OLt` (desugar x)
+desugar (POr x y) = ONot (ONot (desugar x) `OAnd` ONot (desugar y))
+desugar (PImpl x y) = ONot ((desugar x) `OAnd` ONot (desugar y))
diff --git a/benchmark/Functions/Standard/Eval.hs b/benchmark/Functions/Standard/Eval.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Standard/Eval.hs
@@ -0,0 +1,149 @@
+module Functions.Standard.Eval where
+
+import DataTypes.Standard
+import Functions.Standard.Desugar
+import Control.Monad
+
+coerceInt :: (Monad m) => SExpr -> m Int
+coerceInt (SInt i) = return i
+coerceInt _ = fail ""
+
+coerceBool :: (Monad m) => SExpr -> m Bool
+coerceBool (SBool b) = return b
+coerceBool _ = fail ""
+
+coercePair :: (Monad m) => SExpr -> m (SExpr,SExpr)
+coercePair (SPair x y) = return (x,y)
+coercePair _ = fail ""
+
+eval :: (Monad m) => OExpr -> m SExpr
+eval (OInt i) = return $ SInt i
+eval (OBool b) = return $ SBool b
+eval (OPair x y) = liftM2 SPair (eval x) (eval y)
+eval (OPlus x y) = liftM2 (\ x y -> SInt (x + y)) (eval x >>= coerceInt) (eval y >>= coerceInt)
+eval (OMult x y) = liftM2 (\ x y -> SInt (x * y)) (eval x >>= coerceInt) (eval y >>= coerceInt)
+eval (OIf b x y) = eval b >>= coerceBool >>= (\b -> if b then eval x else eval y)
+eval (OEq x y) = liftM2 (\ x y -> SBool (x == y)) (eval x) (eval y)
+eval (OLt x y) = liftM2 (\ x y -> SBool (x < y)) (eval x >>= coerceInt) (eval y >>= coerceInt)
+eval (OAnd x y) = liftM2 (\ x y -> SBool (x && y)) (eval x >>= coerceBool) (eval y >>= coerceBool)
+eval (ONot x) = liftM (SBool . not)(eval x >>= coerceBool)
+eval (OProj p x) = liftM select (eval x >>= coercePair)
+    where select (x,y) = case p of
+                           SProjLeft -> x
+                           SProjRight -> y
+
+evalSugar :: PExpr -> Err SExpr
+evalSugar (PInt i) = return $ SInt i
+evalSugar (PBool b) = return $ SBool b
+evalSugar (PPair x y) = liftM2 SPair (evalSugar x) (evalSugar y)
+evalSugar (PPlus x y) = liftM2 (\ x y -> SInt (x + y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)
+evalSugar (PMult x y) = liftM2 (\ x y -> SInt (x * y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)
+evalSugar (PIf b x y) = evalSugar b >>= coerceBool >>= (\b -> if b then evalSugar x else evalSugar y)
+evalSugar (PEq x y) = liftM2 (\ x y -> SBool (x == y)) (evalSugar x) (evalSugar y)
+evalSugar (PLt x y) = liftM2 (\ x y -> SBool (x < y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)
+evalSugar (PAnd x y) = liftM2 (\ x y -> SBool (x && y)) (evalSugar x >>= coerceBool) (evalSugar y >>= coerceBool)
+evalSugar (PNot x) = liftM (SBool . not)(evalSugar x >>= coerceBool)
+evalSugar (PProj p x) = liftM select (evalSugar x >>= coercePair)
+    where select (x,y) = case p of
+                           SProjLeft -> x
+                           SProjRight -> y
+evalSugar (PNeg x) = liftM (SInt . negate) (evalSugar x >>= coerceInt)
+evalSugar (PMinus x y) = liftM2 (\ x y -> SInt (x - y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)
+evalSugar (PGt x y) = liftM2 (\ x y -> SBool (x > y)) (evalSugar x >>= coerceInt) (evalSugar y >>= coerceInt)
+evalSugar (POr x y) = liftM2 (\ x y -> SBool (x || y)) (evalSugar x >>= coerceBool) (evalSugar y >>= coerceBool)
+evalSugar (PImpl x y) = liftM2 (\ x y -> SBool (not x || y)) (evalSugar x >>= coerceBool) (evalSugar y >>= coerceBool)
+
+desugarEval :: PExpr -> Err SExpr
+desugarEval = eval . desugar
+
+
+coerceInt2 :: SExpr -> Int
+coerceInt2 (SInt i) = i
+coerceInt2 _ = undefined
+
+coerceBool2 :: SExpr -> Bool
+coerceBool2 (SBool b) = b
+coerceBool2 _ = undefined
+
+coercePair2 :: SExpr -> (SExpr,SExpr)
+coercePair2 (SPair x y) = (x,y)
+coercePair2 _ = undefined
+
+eval2 :: OExpr -> SExpr
+eval2 (OInt i) = SInt i
+eval2 (OBool b) = SBool b
+eval2 (OPair x y) = SPair (eval2 x) (eval2 y)
+eval2 (OPlus x y) = (\ x y -> SInt (x + y)) (coerceInt2 $ eval2 x) (coerceInt2 $ eval2 y)
+eval2 (OMult x y) = (\ x y -> SInt (x * y)) (coerceInt2 $ eval2 x) (coerceInt2 $ eval2 y)
+eval2 (OIf b x y) = if coerceBool2 $ eval2 b then eval2 x else eval2 y
+eval2 (OEq x y) = (\ x y -> SBool (x == y)) (eval2 x) (eval2 y)
+eval2 (OLt x y) = (\ x y -> SBool (x < y)) (coerceInt2 $ eval2 x) (coerceInt2 $ eval2 y)
+eval2 (OAnd x y) =(\ x y -> SBool (x && y)) (coerceBool2 $ eval2 x) (coerceBool2 $ eval2 y)
+eval2 (ONot x) = (SBool . not)(coerceBool2 $ eval2 x)
+eval2 (OProj p x) = select (coercePair2 $ eval2 x)
+    where select (x,y) = case p of
+                           SProjLeft -> x
+                           SProjRight -> y
+
+
+evalSugar2 :: PExpr -> SExpr
+evalSugar2 (PInt i) = SInt i
+evalSugar2 (PBool b) =  SBool b
+evalSugar2 (PPair x y) = SPair (evalSugar2 x) (evalSugar2 y)
+evalSugar2 (PPlus x y) = (\ x y -> SInt (x + y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)
+evalSugar2 (PMult x y) = (\ x y -> SInt (x * y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)
+evalSugar2 (PIf b x y) = if coerceBool2 $ evalSugar2 b then evalSugar2 x else evalSugar2 y
+evalSugar2 (PEq x y) = (\ x y -> SBool (x == y)) (evalSugar2 x) (evalSugar2 y)
+evalSugar2 (PLt x y) = (\ x y -> SBool (x < y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)
+evalSugar2 (PAnd x y) = (\ x y -> SBool (x && y)) (coerceBool2 $ evalSugar2 x) (coerceBool2 $ evalSugar2 y)
+evalSugar2 (PNot x) = (SBool . not)(coerceBool2 $ evalSugar2 x)
+evalSugar2 (PProj p x) = select (coercePair2 $ evalSugar2 x)
+    where select (x,y) = case p of
+                           SProjLeft -> x
+                           SProjRight -> y
+evalSugar2 (PNeg x) = (SInt . negate) (coerceInt2 $ evalSugar2 x)
+evalSugar2 (PMinus x y) = (\ x y -> SInt (x - y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)
+evalSugar2 (PGt x y) = (\ x y -> SBool (x > y)) (coerceInt2 $ evalSugar2 x) (coerceInt2 $ evalSugar2 y)
+evalSugar2 (POr x y) = (\ x y -> SBool (x || y)) (coerceBool2 $ evalSugar2 x) (coerceBool2 $ evalSugar2 y)
+evalSugar2 (PImpl x y) = (\ x y -> SBool (not x || y)) (coerceBool2 $ evalSugar2 x) (coerceBool2 $ evalSugar2 y)
+
+desugarEval2 :: PExpr -> SExpr
+desugarEval2 = eval2 . desugar
+
+
+
+
+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/Functions/Standard/FreeVars.hs b/benchmark/Functions/Standard/FreeVars.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Standard/FreeVars.hs
@@ -0,0 +1,73 @@
+module Functions.Standard.FreeVars where
+
+import DataTypes.Standard
+import Data.Generics.PlateDirect
+
+instance Uniplate PExpr where
+    uniplate (PInt x) = plate PInt |- x
+    uniplate (PBool x) = plate PBool |- x
+    uniplate (PPair x y) = plate PPair |* x |* y
+    uniplate (PMult x y) = plate PMult |* x |* y
+    uniplate (PPlus x y) = plate PPlus |* x |* y
+    uniplate (PIf x y z) = plate PIf |* x |* y |* z
+    uniplate (PEq x y) = plate PEq |* x |* y
+    uniplate (PLt x y) = plate PLt |* x |* y
+    uniplate (PAnd x y) = plate PAnd |* x |* y
+    uniplate (PNot x) = plate PNot |* x
+    uniplate (PProj x y) = plate PProj |- x |* y
+    uniplate (PNeg x) = plate PNeg |* x
+    uniplate (PMinus x y) = plate PMinus |* x |* y
+    uniplate (PGt x y) = plate PGt |* x |* y
+    uniplate (POr x y) = plate POr |* x |* y
+    uniplate (PImpl x y) = plate PImpl |* x |* y
+
+
+contVar :: Int -> PExpr -> Bool
+contVar v e = 
+    case e of
+      PInt i -> i == v
+      PBool{} -> False
+      PPair x y -> re x || re y
+      PPlus x y -> re x || re y
+      PMult x y -> re x || re y
+      PIf x y z -> re x || re y || re z
+      PEq x y -> re x || re y
+      PLt x y -> re x || re y
+      PAnd x y -> re x || re y
+      PNot x -> re x
+      PProj _ x -> re x
+      PNeg x -> re x
+      PMinus x y -> re x || re y
+      PGt x y -> re x || re y
+      POr x y -> re x || re y
+      PImpl x y -> re x || re y
+    where re = contVar v
+
+freeVars :: PExpr -> [Int]
+freeVars e = 
+    case e of
+      PInt i -> [i]
+      PBool{} -> []
+      PPair x y -> re2 x y
+      PPlus x y -> re2 x y
+      PMult x y -> re2 x y
+      PIf x y z -> re3 x y z
+      PEq x y -> re2 x y
+      PLt x y -> re2 x y
+      PAnd x y -> re2 x y
+      PNot x -> re x
+      PProj _ x -> re x
+      PNeg x -> re x
+      PMinus x y -> re2 x y
+      PGt x y -> re2 x y
+      POr x y -> re2 x y
+      PImpl x y -> re2 x y
+    where re = freeVars
+          re2 x y = re x ++ re y
+          re3 x y z = re x ++ re y ++ re z
+
+contVarGen :: Int -> PExpr -> Bool
+contVarGen v e = elem v [ j | (PInt j) <- universe e]
+
+freeVarsGen :: PExpr -> [Int]
+freeVarsGen e = [ j | (PInt j) <- universe e]
diff --git a/benchmark/Functions/Standard/Inference.hs b/benchmark/Functions/Standard/Inference.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Functions/Standard/Inference.hs
@@ -0,0 +1,153 @@
+module Functions.Standard.Inference where
+
+import DataTypes.Standard
+import Control.Monad
+import Functions.Standard.Desugar
+
+checkOp :: (Monad m) => [VType] -> VType -> [OExpr] -> m VType
+checkOp tys rety args = do 
+  argsty <- mapM inferType args
+  if tys == argsty
+     then return rety
+     else fail ""
+
+inferType :: (Monad m) => OExpr -> m VType
+inferType (OInt _) = return VTInt
+inferType (OBool _) = return VTBool
+inferType (OPair x y) = liftM2 VTPair (inferType x) (inferType y)
+inferType (OPlus x y) = checkOp [VTInt,VTInt] VTInt [x,y]
+inferType (OMult x y) = checkOp [VTInt,VTInt] VTInt [x,y]
+inferType (OIf b x y) = do [bty,xty,yty] <- mapM inferType [b,x,y]
+                           if (bty == VTBool) && xty == yty
+                             then return xty
+                             else fail ""
+inferType (OLt x y) = checkOp [VTInt,VTInt] VTBool [x,y]
+inferType (OEq x y) = do [xty,yty] <- mapM inferType [x,y]
+                         if xty == yty
+                            then return VTBool
+                            else fail ""
+inferType (OAnd x y) = checkOp [VTBool,VTBool] VTBool [x,y]
+inferType (ONot x) = checkOp [VTBool] VTBool [x]
+inferType (OProj p x) = do xty <- inferType x
+                           case xty of
+                             VTPair s t -> return $
+                                 case p of 
+                                   SProjLeft -> s
+                                   SProjRight -> t
+                             _ -> fail ""
+
+
+checkOpP :: [VType] -> VType -> [PExpr] -> Err VType
+checkOpP tys rety args = do 
+  argsty <- mapM typeSugar args
+  if tys == argsty
+     then return rety
+     else fail ""
+
+--typeSugar :: (Monad m) => PExpr -> m VType
+typeSugar :: PExpr -> Err VType
+typeSugar (PInt _) = return VTInt
+typeSugar (PBool _) = return VTBool
+typeSugar (PPair x y) = liftM2 VTPair (typeSugar x) (typeSugar y)
+typeSugar (PPlus x y) = checkOpP [VTInt,VTInt] VTInt [x,y]
+typeSugar (PMult x y) = checkOpP [VTInt,VTInt] VTInt [x,y]
+typeSugar (PIf b x y) = do [bty,xty,yty] <- mapM typeSugar [b,x,y]
+                           if (bty == VTBool) && xty == yty
+                             then return xty
+                             else fail ""
+typeSugar (PLt x y) = checkOpP [VTInt,VTInt] VTBool [x,y]
+typeSugar (PEq x y) = do [xty,yty] <- mapM typeSugar [x,y]
+                         if xty == yty
+                            then return VTBool
+                            else fail ""
+typeSugar (PAnd x y) = checkOpP [VTBool,VTBool] VTBool [x,y]
+typeSugar (PNot x) = checkOpP [VTBool] VTBool [x]
+typeSugar (PProj p x) = do xty <- typeSugar x
+                           case xty of
+                             VTPair s t -> return $
+                                 case p of 
+                                   SProjLeft -> s
+                                   SProjRight -> t
+                             _ -> fail ""
+typeSugar (PNeg x) = checkOpP [VTInt] VTInt [x]
+typeSugar (PMinus x y) = checkOpP [VTInt,VTInt] VTInt [x,y]
+typeSugar (PGt x y) = checkOpP [VTInt,VTInt] VTBool [x,y]
+typeSugar (POr x y) = checkOpP [VTBool,VTBool] VTBool [x,y]
+typeSugar (PImpl x y) = checkOpP [VTBool,VTBool] VTBool [x,y]
+
+desugarType :: PExpr -> Err VType
+desugarType = inferType . desugar
+
+-- non-monadic
+
+checkOp2 :: [VType] -> VType -> [OExpr] -> VType
+checkOp2 tys rety args = 
+  if tys == map inferType2 args
+     then rety
+     else error ""
+
+inferType2 :: OExpr -> VType
+inferType2 (OInt _) = VTInt
+inferType2 (OBool _) = VTBool
+inferType2 (OPair x y) = VTPair (inferType2 x) (inferType2 y)
+inferType2 (OPlus x y) = checkOp2 [VTInt,VTInt] VTInt [x,y]
+inferType2 (OMult x y) = checkOp2 [VTInt,VTInt] VTInt [x,y]
+inferType2 (OIf b x y) =  let [bty,xty,yty] = map inferType2 [b,x,y]
+                         in if (bty == VTBool) && xty == yty
+                             then xty
+                             else error ""
+inferType2 (OLt x y) = checkOp2 [VTInt,VTInt] VTBool [x,y]
+inferType2 (OEq x y) = let [xty,yty] = map inferType2 [x,y]
+                      in if xty == yty
+                            then VTBool
+                            else error ""
+inferType2 (OAnd x y) = checkOp2 [VTBool,VTBool] VTBool [x,y]
+inferType2 (ONot x) = checkOp2 [VTBool] VTBool [x]
+inferType2 (OProj p x) = let xty = inferType2 x
+                        in case xty of
+                             VTPair s t -> 
+                                 case p of 
+                                   SProjLeft -> s
+                                   SProjRight -> t
+                             _ -> error ""
+
+
+checkOpP2 :: [VType] -> VType -> [PExpr] -> VType
+checkOpP2 tys rety args = 
+  if tys == map typeSugar2 args
+     then rety
+     else error ""
+
+--typeSugar :: (Monad m) => PExpr -> m VType
+typeSugar2 :: PExpr -> VType
+typeSugar2 (PInt _) = VTInt
+typeSugar2 (PBool _) = VTBool
+typeSugar2 (PPair x y) = VTPair (typeSugar2 x) (typeSugar2 y)
+typeSugar2 (PPlus x y) = checkOpP2 [VTInt,VTInt] VTInt [x,y]
+typeSugar2 (PMult x y) = checkOpP2 [VTInt,VTInt] VTInt [x,y]
+typeSugar2 (PIf b x y) = let [bty,xty,yty] = map typeSugar2 [b,x,y]
+                        in if (bty == VTBool) && xty == yty
+                             then xty
+                             else error ""
+typeSugar2 (PLt x y) = checkOpP2 [VTInt,VTInt] VTBool [x,y]
+typeSugar2 (PEq x y) = let [xty,yty] = map typeSugar2 [x,y]
+                      in if xty == yty
+                            then VTBool
+                            else error ""
+typeSugar2 (PAnd x y) = checkOpP2 [VTBool,VTBool] VTBool [x,y]
+typeSugar2 (PNot x) = checkOpP2 [VTBool] VTBool [x]
+typeSugar2 (PProj p x) = let xty = typeSugar2 x
+                        in case xty of
+                             VTPair s t -> 
+                                 case p of 
+                                   SProjLeft -> s
+                                   SProjRight -> t
+                             _ -> error ""
+typeSugar2 (PNeg x) = checkOpP2 [VTInt] VTInt [x]
+typeSugar2 (PMinus x y) = checkOpP2 [VTInt,VTInt] VTInt [x,y]
+typeSugar2 (PGt x y) = checkOpP2 [VTInt,VTInt] VTBool [x,y]
+typeSugar2 (POr x y) = checkOpP2 [VTBool,VTBool] VTBool [x,y]
+typeSugar2 (PImpl x y) = checkOpP2 [VTBool,VTBool] VTBool [x,y]
+
+desugarType2 :: PExpr -> VType
+desugarType2 = inferType2 . desugar
diff --git a/benchmark/Multi/DataTypes/Comp.hs b/benchmark/Multi/DataTypes/Comp.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Multi/DataTypes/Comp.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  FlexibleInstances,
+  FlexibleContexts,
+  TypeOperators,
+  GADTs,
+  KindSignatures,
+  IncoherentInstances #-}
+
+-- base values
+
+module Multi.DataTypes.Comp where
+
+import Data.Comp.Derive
+import Data.Comp.Multi
+
+type ValueExpr = HTerm Value
+type ExprSig = Value :++: Op
+type Expr = HTerm ExprSig
+type SugarSig = Value :++: Op :++: Sugar
+type SugarExpr = HTerm SugarSig
+type BaseType = HTerm ValueT
+
+data ValueT e t = TInt
+                | TBool
+                | TPair (e t) (e t)
+          deriving (Eq)
+
+data Value e t where
+    VInt :: Int -> Value e Int
+    VBool :: Bool -> Value e Bool
+    VPair :: e s -> e t -> Value e (s,t)
+
+data Op e t where
+    Plus :: e Int -> e Int -> Op e Int
+    Mult :: e Int -> e Int -> Op e Int
+    If :: e Bool -> e t -> e t -> Op e t
+    Lt :: e Int -> e Int -> Op e Bool
+    Eq :: e Int -> e Int -> Op e Bool
+    And :: e Bool -> e Bool -> Op e Bool
+    Not :: e Bool -> Op e Bool
+    ProjLeft :: e (s,t) -> Op e s
+    ProjRight :: e (s,t) -> Op e t
+
+data Sugar e t where
+    Neg  :: e Int -> Sugar e Int
+    Minus :: e Int -> e Int -> Sugar e Int
+    Gt :: e Int -> e Int -> Sugar e Bool
+    Or :: e Bool -> e Bool -> Sugar e Bool
+    Impl :: e Bool -> e Bool -> Sugar e Bool
+
+$(derive
+  [instanceHFunctor, instanceHFoldable, instanceHTraversable, instanceHEqF, smartHConstructors]
+  [''ValueT, ''Value, ''Op, ''Sugar])
+
+
+showBinOp :: String -> String -> String -> String
+showBinOp op x y = "("++ x ++ op ++ y ++ ")"
+
+instance HShowF ValueT where
+    hshowF' TInt = "Int"
+    hshowF' TBool = "Bool"
+    hshowF' (TPair (K x) (K y)) = showBinOp "," x y
+
+instance HShowF Value where
+    hshowF' (VInt i) = show i
+    hshowF' (VBool b) = show b
+    hshowF' (VPair (K x) (K y)) = showBinOp "," x y
+
+instance HShowF Op where
+    hshowF' (Plus (K x) (K y)) = showBinOp "+" x y
+    hshowF' (Mult (K x) (K y)) = showBinOp "*" x y
+    hshowF' (If (K b) (K x) (K y)) = "if " ++ b ++ " then " ++ x ++ " else " ++ y ++ " fi"
+    hshowF' (Eq (K x) (K y)) = showBinOp "==" x y
+    hshowF' (Lt (K x) (K y)) = showBinOp "<" x y
+    hshowF' (And (K x) (K y)) = showBinOp "&&" x y
+    hshowF' (Not (K x)) = "~" ++ x
+    hshowF' (ProjLeft (K x)) = x ++ "!0"
+    hshowF' (ProjRight (K x)) = x ++ "!1"
diff --git a/benchmark/Multi/Functions/Comp/Desugar.hs b/benchmark/Multi/Functions/Comp/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Multi/Functions/Comp/Desugar.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances,
+  GADTs#-}
+
+module Multi.Functions.Comp.Desugar where
+
+import Multi.DataTypes.Comp
+import Data.Comp.Multi
+
+-- de-sugar
+
+class (HFunctor e, HFunctor f) => Desugar f e where
+    desugarAlg :: HTermHom f e
+    desugarAlg = desugarAlg' . hfmap HHole
+    desugarAlg' :: HAlg f (HContext e a)
+    desugarAlg' x = appHCxt $ desugarAlg x
+
+desugarExpr :: SugarExpr :-> Expr
+desugarExpr = desugar
+
+desugar :: Desugar f e => HTerm f :-> HTerm e
+desugar = appHTermHom desugarAlg
+
+instance (Desugar f e, Desugar g e) => Desugar (g :++: f) e where
+    desugarAlg (HInl v) = desugarAlg v
+    desugarAlg (HInr v) = desugarAlg v
+
+instance (Value :<<: v, HFunctor v) => Desugar Value v where
+    desugarAlg = liftHCxt
+
+instance (Op :<<: v, HFunctor v) => Desugar Op v where
+    desugarAlg = liftHCxt
+
+instance (Op :<<: v, Value :<<: v, HFunctor v) => Desugar Sugar v where
+    desugarAlg' (Neg x) =  iVInt (-1) `iMult` x
+    desugarAlg' (Minus x y) =  x `iPlus` ((iVInt (-1)) `iMult` y)
+    desugarAlg' (Gt x y) =  y `iLt` x
+    desugarAlg' (Or x y) = iNot (iNot x `iAnd` iNot y)
+    desugarAlg' (Impl x y) = iNot (x `iAnd` iNot y)
diff --git a/benchmark/Multi/Functions/Comp/Eval.hs b/benchmark/Multi/Functions/Comp/Eval.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Multi/Functions/Comp/Eval.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE
+  GADTs,
+  TemplateHaskell,
+  MultiParamTypeClasses,
+  FlexibleInstances,
+  FlexibleContexts,
+  UndecidableInstances,
+  TypeOperators,
+  ScopedTypeVariables,
+  TypeSynonymInstances#-}
+
+module Multi.Functions.Comp.Eval where
+
+import Multi.DataTypes.Comp
+import Multi.Functions.Comp.Desugar
+import Data.Comp.Multi
+import Data.Comp.Multi.HEquality
+
+-- evaluation
+
+class Eval e v where
+    evalAlg :: Alg e (Term v)
+
+eval :: (HFunctor e, Eval e v) => Term e :-> (Term v)
+eval = cata evalAlg
+
+instance (Eval f v, Eval g v) => Eval (f :++: g) v where
+    evalAlg (HInl v) = evalAlg v
+    evalAlg (HInr v) = evalAlg v
+
+instance (Value :<<: v) => Eval Value v where
+    evalAlg = inject
+
+
+getInt :: (Value :<<: v) => Term v Int -> Int
+getInt t = case project t of
+             Just (VInt x) -> x
+             Nothing -> undefined
+getBool :: (Value :<<: v) => Term v Bool -> Bool
+getBool t = case project t of
+             Just (VBool x) -> x
+             Nothing -> undefined
+
+getPair :: (Value :<<: v) => Term v (s,t) -> ((Term v s), (Term v t))
+getPair t = case project t of
+              Just (VPair x y) -> (x, y)
+              Nothing -> undefined
+
+
+instance (Value :<<: v, HEqF v) => Eval Op v where
+    evalAlg (Plus x y) = iVInt $ getInt x + getInt y
+    evalAlg (Mult x y) = iVInt $ getInt x * getInt y
+    evalAlg (If b x y) = if getBool b then x else y
+    evalAlg (Eq x y) = iVBool $ x == y
+    evalAlg (Lt x y) = iVBool $ getInt x < getInt y
+    evalAlg (And x y) = iVBool $ getBool x && getBool y
+    evalAlg (Not x) = iVBool $ not $ getBool x
+    evalAlg (ProjLeft x) = fst $ getPair x
+    evalAlg (ProjRight x) = snd $ getPair x
+
+instance (Value :<<: v) => Eval Sugar v where
+    evalAlg (Neg x) = iVInt $ negate $ getInt x
+    evalAlg (Minus x y) = iVInt $ getInt x - getInt y
+    evalAlg (Gt x y) = iVBool $ getInt x > getInt y
+    evalAlg (Or x y) = iVBool $ getBool x || getBool y
+    evalAlg (Impl x y) = iVBool $ not (getBool x) || getBool y
+
+desugarEval :: SugarExpr :-> ValueExpr
+desugarEval = eval . (desugar :: SugarExpr :-> Expr)
+
+evalSugar :: SugarExpr :-> ValueExpr
+evalSugar = eval
+
+desugarEvalAlg  :: Alg SugarSig ValueExpr
+desugarEvalAlg = evalAlg  `compAlg` (desugarAlg :: TermHom SugarSig ExprSig)
+
+desugarEval' :: SugarExpr :-> ValueExpr
+desugarEval' e = cata desugarEvalAlg e
diff --git a/benchmark/Transformations.hs b/benchmark/Transformations.hs
new file mode 100644
--- /dev/null
+++ b/benchmark/Transformations.hs
@@ -0,0 +1,27 @@
+module Transformations where
+
+import DataTypes
+import Data.Comp
+
+
+toBaseExp :: Term Value -> BaseExp
+toBaseExp = algHom toBaseExpAlg
+    where toBaseExpAlg (VInt i) = BInt i
+          toBaseExpAlg (VBool b) = BBool b
+          toBaseExpAlg (VString s) = BString s
+          toBaseExpAlg (VDateTime d) = BDateTime d
+          toBaseExpAlg (VDuration d) = BDuration d
+          toBaseExpAlg (VDouble d) = BDouble d
+          toBaseExpAlg (VRecord r) = BRecord r
+          toBaseExpAlg (VList l) = BList l
+
+toRepExp :: Term Value -> RepExp
+toRepExp = algHom toRepExpAlg
+    where toRepExpAlg (VInt i) = RInt i
+          toRepExpAlg (VBool b) = RBool b
+          toRepExpAlg (VString s) = RString s
+          toRepExpAlg (VDateTime d) = RDateTime d
+          toRepExpAlg (VDuration d) = RDuration d
+          toRepExpAlg (VDouble d) = RDouble d
+          toRepExpAlg (VRecord r) = RRecord r
+          toRepExpAlg (VList l) = RList l
diff --git a/compdata.cabal b/compdata.cabal
new file mode 100644
--- /dev/null
+++ b/compdata.cabal
@@ -0,0 +1,170 @@
+Name:			compdata
+Version:		0.1
+Synopsis:            	Compositional Data Types
+Description:
+
+  Based on Wouter Swierstra's Functional Pearl /Data types à la carte/
+  (Journal of Functional Programming, 18(4):423-436, 2008),
+  this package provides a framework for defining recursive
+  data types in a compositional manner. The fundamental idea of
+  compositional data types is to separate the signature of a data type
+  from the fixed point construction that produces its recursive
+  structure. By allowing to compose and decompose signatures,
+  /compositional data types/ enable to combine data types in a flexible
+  way. The key point of Wouter Swierstra's original work is to define
+  functions on /compositional data types/ in a compositional manner as
+  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
+  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
+  suited for programming language implementations, especially, in an environment
+  consisting of a family of tightly interwoven /domain-specific languages/.
+  .
+  In concrete terms, this package provides the following features:
+  .
+  *  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
+     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.
+  .
+  *  Support for monadic computations via monadic variants of all
+     recursion schemes.
+  .
+  *  Support of a succinct programming style over compositional data types
+     via generic programming combinators that allow various forms of
+     generic transformations and generic queries.
+  .
+  *  Generalisation of compositional data types (terms) to
+     compositional data types \"with holes\" (contexts). This allows
+     flexible reuse of a wide variety of catamorphisms (called
+     /term homomorphisms/) as well as an efficient composition of them.
+  .
+  *  Operations on signatures, for example, to add and remove
+     annotations of abstract syntax trees. This includes combinators to
+     propagate annotations fully automatically through certain
+     term homomorphisms.
+  .
+  *  Optimisation of the implementation of recursion schemes. This
+     includes /short-cut fusion/ style optimisation rules which yield a
+     performance boost of up to factor six.
+  .
+  *  Efficient implementation of catamorphisms on non-polynomial
+     signatures that contain function types. This allows to represent
+     /higher-order abstract syntax/ with compositional data types.
+  .
+  *  Automatic derivation of instances of all relevant type classes for
+     using compositional data types via /Template Haskell/. This includes
+     instances of 'Prelude.Eq', 'Prelude.Ord' and 'Prelude.Show' that are
+     derived via instances for functorial variants of them. Additionally,
+     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.
+  .
+  For examples illustrating the use of compositional data types, consult
+  "Data.Comp" resp. "Data.Comp.Multi" for mutually recursive data types.
+
+Category:            	Generics
+License:		BSD3
+License-file:		LICENSE
+Author:			Patrick Bahr, Tom Hvitved
+Maintainer:		paba@diku.dk
+Build-Type:		Custom
+Cabal-Version:          >=1.8.0.6
+
+extra-source-files:
+  -- test files
+  testsuite/tests/Data_Test.hs,
+  testsuite/tests/Data/Comp_Test.hs,
+  testsuite/tests/Data/Comp/Equality_Test.hs,
+  testsuite/tests/Test/Utils.hs
+  -- benchmark files
+  benchmark/Benchmark.hs
+  benchmark/DataTypes.hs
+  benchmark/Functions.hs
+  benchmark/DataTypes/Comp.hs
+  benchmark/DataTypes/Transform.hs
+  benchmark/DataTypes/Standard.hs
+  benchmark/Multi/DataTypes/Comp.hs
+  benchmark/Multi/Functions/Comp/Eval.hs
+  benchmark/Multi/Functions/Comp/Desugar.hs
+  benchmark/Transformations.hs
+  benchmark/Functions/Comp.hs
+  benchmark/Functions/Comp/Eval.hs
+  benchmark/Functions/Comp/Desugar.hs
+  benchmark/Functions/Comp/FreeVars.hs
+  benchmark/Functions/Comp/Inference.hs
+  benchmark/Functions/Standard/Eval.hs
+  benchmark/Functions/Standard/Desugar.hs
+  benchmark/Functions/Standard/FreeVars.hs
+  benchmark/Functions/Standard/Inference.hs
+  benchmark/Functions/Standard.hs
+
+
+flag test
+  description: Build test executable.
+  default:     False
+
+flag benchmark
+  description: Build benchmark executable.
+  default:     False
+
+
+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,
+                        Data.Comp.Multi.Functor, Data.Comp.Multi.ExpFunctor,
+                        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.ExpFunctor
+
+  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.Foldable, Data.Comp.Derive.ExpFunctor,
+                        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.ExpFunctor,
+                        Data.Comp.Derive.Multi.SmartConstructors
+
+  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, th-expand-syns
+  hs-source-dirs:	src
+  ghc-options:          -W
+
+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
+  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
+  hs-source-dirs:	src benchmark
+  ghc-options:          -W -O2
+  -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.
+  cpp-options:          -DNO_RULES
+  if !flag(benchmark)
+    buildable:     False
diff --git a/src/Data/Comp.hs b/src/Data/Comp.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp.hs
@@ -0,0 +1,429 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@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.
+--
+--------------------------------------------------------------------------------
+module Data.Comp(
+  -- * Examples
+  -- ** Pure Computations
+  -- $ex1
+
+  -- ** Monadic Computations
+  -- $ex2
+
+  -- ** Composing Term Homomorphisms and Algebras
+  -- $ex3
+
+  -- ** Lifting Term Homomorphisms to Products
+  -- $ex4
+
+  -- ** Higher-Order Abstract Syntax
+  -- $ex5
+    module Data.Comp.Term
+  , module Data.Comp.Algebra
+  , module Data.Comp.Sum
+  , module Data.Comp.Product
+  , module Data.Comp.Equality
+  , module Data.Comp.Ordering
+  , module Data.Comp.Generic
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Algebra
+import Data.Comp.Sum
+import Data.Comp.Product
+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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Algebra.hs
@@ -0,0 +1,581 @@
+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators,
+  FlexibleContexts, CPP #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Algebra
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@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.Algebra (
+      -- * Algebras & Catamorphisms
+      Alg,
+      free,
+      cata,
+      cata',
+      appCxt,
+      
+      -- * Monadic Algebras & Catamorphisms
+      AlgM,
+      algM,
+      freeM,
+      cataM,
+      cataM',
+
+      -- * Term Homomorphisms
+      CxtFun,
+      SigFun,
+      TermHom,
+      appTermHom,
+      compTermHom,
+      appSigFun,
+      compSigFun,
+      termHom,
+      compAlg,
+      compCoalg,
+      compCVCoalg,
+
+      -- * Monadic Term Homomorphisms
+      CxtFunM,
+      SigFunM,
+      TermHomM,
+      SigFunM',
+      TermHomM',
+      sigFunM,
+      termHom',
+      appTermHomM,
+      termHomM,
+      termHomM',
+      appSigFunM,
+      appSigFunM',
+      compTermHomM,
+      compSigFunM,
+      compAlgM,
+      compAlgM',
+
+      -- * Coalgebras & Anamorphisms
+      Coalg,
+      ana,
+      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,
+
+      -- * Exponential Functors
+      appTermHomE,
+      cataE,
+      anaE,
+      appCxtE
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Ops
+import Data.Traversable
+import Control.Monad hiding (sequence, mapM)
+import Data.Comp.ExpFunctor
+
+import Prelude hiding (sequence, mapM)
+
+
+
+{-| This type represents an algebra over a functor @f@ and carrier
+@a@. -}
+
+type Alg f a = f a -> a
+
+{-| Construct a catamorphism for contexts over @f@ with holes of type @a@, from
+  the given algebra. -}
+free :: forall f h a b . (Functor f) => Alg f b -> (a -> b) -> Cxt h f a -> b
+free f g = run
+    where run :: Cxt h f a -> b
+          run (Hole x) = g x
+          run (Term t) = f (fmap run t)
+
+{-| Construct a catamorphism from the given algebra. -}
+cata :: forall f a . (Functor f) => Alg f a -> Term f -> a 
+{-# NOINLINE [1] cata #-}
+-- cata f = free f undefined
+-- the above definition is safe since terms do not contain holes
+--
+-- a direct implementation:
+cata f = run 
+    where run :: Term f -> a
+          run  = f . fmap run . unTerm
+
+
+{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where
+  the holes have the type of the algebra carrier. -}
+cata' :: (Functor f) => Alg f a -> Cxt h f a -> a
+{-# INLINE cata' #-}
+cata' f = free f id
+
+
+{-| This function applies a whole context into another context. -}
+
+appCxt :: (Functor f) => Context f (Cxt h f a) -> Cxt h f a
+-- appCxt = cata' Term
+appCxt (Hole x) = x
+appCxt (Term t) = Term (fmap appCxt t)
+
+
+
+{-| This type represents a monadic algebra. It is similar to 'Alg' but
+the return type is monadic.  -}
+
+type AlgM m f a = f a -> m a 
+
+{-| Convert a monadic algebra into an ordinary algebra with a monadic
+  carrier. -}
+algM :: (Traversable f, Monad m) => AlgM m f a -> Alg f (m a)
+algM f x = sequence x >>= f
+
+{-| Construct a monadic catamorphism for contexts over @f@ with holes of type
+  @a@, from the given monadic algebra. -}
+freeM :: forall h f a m b. (Traversable f, Monad m) =>
+               AlgM m f b -> (a -> m b) -> Cxt h f a -> m b
+-- freeM alg var = free (algM alg) var
+freeM algm var = run
+    where run :: Cxt h f a -> m b
+          run (Hole x) = var x
+          run (Term t) = algm =<< mapM run t
+
+{-| Construct a monadic catamorphism from the given monadic algebra. -}
+cataM :: forall f m a. (Traversable f, Monad m) => AlgM m f a -> Term f -> m a 
+{-# NOINLINE [1] cataM #-}
+-- cataM = cata . algM
+cataM algm = run
+    where run :: Term f -> m a
+          run = algm <=< mapM run . unTerm
+
+{-| 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 h f a m . (Traversable f, Monad m)
+            => AlgM m f a -> Cxt h f a -> m a
+{-# NOINLINE [1] cataM' #-}
+-- cataM' f = free (\x -> sequence x >>= f) return
+cataM' f = run
+    where run :: Cxt h f a -> m a
+          run (Hole x) = return x
+          run (Term t) = f =<< mapM run t
+
+
+{-| This type represents a context function. -}
+type CxtFun f g = forall a h. Cxt h f a -> Cxt h g a
+
+{-| This type represents a signature function.-}
+type SigFun f g = forall a. f a -> g a
+
+{-| 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
+{-# 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))
+
+{-| Compose two term homomorphisms. -}
+compTermHom :: (Functor g, Functor 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))
+-- -> (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
+
+{-| Compose an algebra with a term homomorphism to get a new algebra. -}
+compAlg :: (Functor g) => Alg g a -> TermHom f g -> Alg f a
+compAlg alg talg = cata' alg . talg
+
+{-| Compose a term homomorphism with a coalgebra to get a cv-coalgebra. -}
+compCoalg :: TermHom f g -> Coalg f a -> CVCoalg' g a
+compCoalg hom coa = hom . coa
+
+{-| Compose a term homomorphism with a cv-coalgebra to get a new cv-coalgebra.
+ -}
+compCVCoalg :: (Functor f, Functor g)
+  => TermHom f g -> CVCoalg' f a -> CVCoalg' g a
+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
+
+
+{-| 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 :: (Functor g) => SigFun f g -> TermHom f g
+termHom f = simpCxt . f
+
+{-|
+  This type represents a monadic context function.
+-}
+type CxtFunM m f g = forall a h. Cxt h f a -> m (Cxt h g a)
+
+{-| This type represents a monadic signature function. -}
+
+type SigFunM m f g = forall a. f a -> m (g a)
+
+{-| 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)
+
+{-| 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)
+
+
+{-| 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' :: (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
+
+
+{-| Apply a monadic term homomorphism recursively to a term/context. -}
+appTermHomM :: forall f g m . (Traversable f, Functor 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 (f =<< mapM run 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 
+    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
+
+{-| 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 
+    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
+
+{-| 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
+compAlgM' alg talg = cataM' 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 a = g a >>= f
+
+----------------
+-- Coalgebras --
+----------------
+
+{-| This type represents a coalgebra over a functor @f@ and carrier @a@. -}
+type Coalg f a = a -> f a
+
+{-| Construct an anamorphism from the given coalgebra. -}
+ana :: forall a f . Functor f => Coalg f a -> a -> Term f
+ana f = run
+    where run :: a -> Term f
+          run t = Term $ fmap run (f t)
+
+-- | Shortcut fusion variant of 'ana'.
+ana' :: forall a f . Functor f => Coalg f a -> a -> Term f
+ana' f t = build $ run t
+    where run :: forall b . a -> Alg f b -> b
+          run t con = run' t where
+              run' :: a ->  b
+              run' t = con $ fmap run' (f t)
+
+build :: (forall a. Alg f a -> a) -> Term f
+{-# INLINE [1] build #-}
+build g = g Term
+
+{-| This type represents a monadic coalgebra over a functor @f@ and carrier
+  @a@. -}
+type CoalgM m f a = a -> m (f a)
+
+{-| Construct a monadic anamorphism from the given monadic coalgebra. -}
+anaM :: forall a m f. (Traversable f, Monad m)
+          => CoalgM m f a -> a -> m (Term f)
+anaM f = run 
+    where run :: a -> m (Term f)
+          run t = liftM Term $ f t >>= mapM run
+
+
+--------------------------------
+-- R-Algebras & Paramorphisms --
+--------------------------------
+
+{-| This type represents an r-algebra over a functor @f@ and carrier @a@. -}
+type RAlg f a = f (Term f, a) -> a
+
+{-| Construct a paramorphism from the given r-algebra. -}
+para :: (Functor f) => RAlg f a -> Term f -> a
+para f = snd . cata run
+    where run t = (Term $ fmap fst t, f t)
+
+{-| This type represents a monadic r-algebra over a functor @f@ and carrier
+  @a@. -}
+type RAlgM m f a = f (Term f, a) -> m a
+
+{-| Construct a monadic paramorphism from the given monadic r-algebra. -}
+paraM :: (Traversable f, Monad m) => 
+         RAlgM m f a -> Term f -> m a
+paraM f = liftM snd . cataM run
+    where run t = do
+            a <- f t
+            return (Term $ fmap fst t, a)
+
+--------------------------------
+-- R-Coalgebras & Apomorphisms --
+--------------------------------
+
+{-| This type represents an r-coalgebra over a functor @f@ and carrier @a@. -}
+type RCoalg f a = a -> f (Either (Term f) a)
+
+{-| Construct an apomorphism from the given r-coalgebra. -}
+apo :: (Functor f) => RCoalg f a -> a -> Term f
+apo f = run 
+    where run = Term . fmap run' . f
+          run' (Left t) = t
+          run' (Right a) = run a
+-- can also be defined in terms of anamorphisms (but less
+-- efficiently):
+-- apo f = ana run . Right
+--     where run (Left (Term t)) = fmap Left t
+--           run (Right a) = f a
+
+{-| This type represents a monadic r-coalgebra over a functor @f@ and carrier
+  @a@. -}
+type RCoalgM m f a = a -> m (f (Either (Term f) a))
+
+{-| Construct a monadic apomorphism from the given monadic r-coalgebra. -}
+apoM :: (Traversable f, Monad m) =>
+        RCoalgM m f a -> a -> m (Term f)
+apoM f = run 
+    where run a = do
+            t <- f a
+            t' <- mapM run' t
+            return $ Term t'
+          run' (Left t) = return t
+          run' (Right a) = run a
+
+-- can also be defined in terms of anamorphisms (but less
+-- efficiently):
+-- apoM f = anaM run . Right
+--     where run (Left (Term t)) = return $ fmap Left t
+--           run (Right a) = f a
+
+
+----------------------------------
+-- CV-Algebras & Histomorphisms --
+----------------------------------
+
+{-| This type represents a cv-algebra over a functor @f@ and carrier @a@. -}
+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
+
+{-| Construct a histomorphism from the given cv-algebra. -}
+histo :: (Functor f,DistProd f a f') => CVAlg f a f' -> Term f -> a
+histo alg  = snd . projectTip . cata run
+    where run v = Term $ injectP (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') =>
+          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
+
+-----------------------------------
+-- CV-Coalgebras & Futumorphisms --
+-----------------------------------
+
+{-| This type represents a cv-coalgebra over a functor @f@ and carrier @a@. -}
+type CVCoalg f a = a -> f (Context f a)
+
+{-| Construct a futumorphism from the given cv-coalgebra. -}
+futu :: forall f a . Functor f => CVCoalg f a -> a -> Term f
+futu coa = ana run . Hole
+    where run :: Coalg f (Context f a)
+          run (Hole x) = coa x
+          run (Term t) = t
+
+{-| This type represents a monadic cv-coalgebra over a functor @f@ and carrier
+  @a@. -}
+type CVCoalgM m f a = a -> m (f (Context f a))
+
+{-| Construct a monadic futumorphism from the given monadic cv-coalgebra. -}
+futuM :: forall f a m . (Traversable f, Monad m) =>
+         CVCoalgM m f a -> a -> m (Term f)
+futuM coa = anaM run . Hole
+    where run :: CoalgM m f (Context f a)
+          run (Hole x) = coa x
+          run (Term t) = return t
+
+{-| This type represents a generalised cv-coalgebra over a functor @f@ and
+  carrier @a@. -}
+type CVCoalg' f a = a -> Context f a
+
+{-| Construct a futumorphism from the given generalised cv-coalgebra. -}
+futu' :: forall f a . Functor f => CVCoalg' f a -> a -> Term f
+futu' coa = run
+    where run :: a -> Term f
+          run x = appCxt $ fmap run (coa x)
+
+--------------------------
+-- Exponential Functors --
+--------------------------
+
+{-| Catamorphism for exponential functors. The intermediate 'cataFS' originates
+ from <http://comonad.com/reader/2008/rotten-bananas/>. -}
+cataE :: forall f a . ExpFunctor f => Alg f a -> Term f -> a
+{-# NOINLINE [1] cataE #-}
+cataE f = cataFS . toCxt
+    where cataFS :: ExpFunctor f => Context f a -> a
+          cataFS (Hole x) = x
+          cataFS (Term t) = f (xmap cataFS Hole t)
+
+{-| Anamorphism for exponential functors. -}
+anaE :: forall a f . ExpFunctor f => Coalg f a -> a -> Term f
+anaE f = cataE (Term . removeP) . anaFS
+    where anaFS :: a -> Term (f :&: a)
+          anaFS t = Term $ xmap anaFS (snd . projectP . unTerm) (f t) :&: t
+
+-- | Variant of 'appCxt' for contexts over 'ExpFunctor' signatures.
+appCxtE :: (ExpFunctor f) => Context f (Cxt h f a) -> Cxt h f a
+appCxtE (Hole x) = x
+appCxtE (Term t) = Term (xmap appCxtE Hole t)
+
+-- | Variant of 'appTermHom' for term homomorphisms from and to
+-- 'ExpFunctor' signatures.
+appTermHomE :: forall f g . (ExpFunctor f, ExpFunctor g) => TermHom f g
+            -> Term f -> Term g
+appTermHomE f = cataFS . toCxt
+    where cataFS :: Context f (Term g) -> Term g
+          cataFS (Hole x) = x
+          cataFS (Term t) = appCxtE (f (xmap cataFS Hole t))
+
+
+-------------------
+-- 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;
+
+  "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.
+    appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;
+
+  "cataE/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) (x :: ExpFunctor f => Term f) .
+    cataE a (appTermHom h x) = cataE (compAlg a h) 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/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) (h :: TermHomM m f g) 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/Arbitrary.hs b/src/Data/Comp/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Arbitrary.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE TypeOperators, TypeSynonymInstances, GADTs, TemplateHaskell, FlexibleInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Arbitrary
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines generation of arbitrary values for signatures, which
+-- lifts to generating arbitrary terms.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Arbitrary
+    ( ArbitraryF(..)
+    )where
+
+import Test.QuickCheck
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Product
+import Data.Comp.Derive.Utils
+import Data.Comp.Derive
+import Control.Applicative
+
+{-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary'
+for the corresponding term type. -}
+
+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'
+        where addP (i,gen) =  (i,(:&:) <$> gen <*> arbitrary)
+    arbitraryF = (:&:) <$> arbitraryF <*> arbitrary
+    shrinkF (v :&: p) = tail [v' :&: p'| v' <- v: shrinkF v, p' <- p : shrink p ]
+
+{-|
+  This lifts instances of 'ArbitraryF' to instances of 'ArbitraryF' for 
+  the corresponding context functor.
+-}
+instance (ArbitraryF f) => ArbitraryF (Context f) where
+    arbitraryF = oneof [Term <$> arbitraryF , Hole <$> arbitrary]
+    shrinkF (Term expr) = map Term $ shrinkF expr
+    shrinkF (Hole a) = map Hole $ shrink a
+
+
+{-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary'
+for the corresponding context type.  -}
+
+instance (ArbitraryF f, Arbitrary a) => Arbitrary (Context f a) where
+    arbitrary = arbitraryF
+    shrink = shrinkF
+
+
+{-| Instances of 'ArbitraryF' are closed under forming sums.  -}
+
+instance (ArbitraryF f , ArbitraryF g) => ArbitraryF (f :+: g) where
+    arbitraryF' = map inl arbitraryF' ++ map inr arbitraryF'
+        where inl (i,gen) = (i,Inl <$> gen)
+              inr (i,gen) = (i,Inr <$> gen)
+    shrinkF (Inl val) = map Inl (shrinkF val)
+    shrinkF (Inr val) = map Inr (shrinkF val)
+
+
+$(derive [instanceArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)
diff --git a/src/Data/Comp/Automata.hs b/src/Data/Comp/Automata.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Automata.hs
@@ -0,0 +1,147 @@
+{-# 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/Decompose.hs b/src/Data/Comp/Decompose.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Decompose.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Decompose
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module implements the decomposition of terms into function
+-- symbols and arguments resp. variables.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Decompose (
+  Decomp (..),
+  DecompTerm,
+  Decompose (..),
+  structure,
+  arguments,
+  decompose
+  ) where
+
+import Data.Comp.Term
+import Data.Comp.Variables
+import Data.Foldable
+
+{-| This function computes the structure of a functorial value. -}
+
+structure :: (Functor f) => f a -> Const f
+structure = fmap (const ())
+
+{-| This function computes the arguments of a functorial value.  -}
+
+arguments :: (Foldable f) => f a -> [a]
+arguments = toList
+
+{-| This type represents decompositions of functorial values. -}
+
+data Decomp f v a = Var v
+                  | Fun (Const f) [a]
+
+{-| This type represents decompositions of terms.  -}
+
+type DecompTerm f v = Decomp f v (Term f)
+
+{-| This class specifies the decomposability of a functorial value. -}
+
+class (HasVars f v, Functor f, Foldable f) => Decompose f v where
+    {-| This function decomposes a functorial value. -}
+
+    decomp :: f a -> Decomp f v a
+    decomp t = case isVar t of
+                 Just v -> Var v
+                 Nothing -> Fun sym args
+                     where sym = fmap (const ()) t
+                           args = arguments t
+
+instance (HasVars f v, Functor f, Foldable f) => Decompose f v where
+
+
+{-| This function decomposes a term. -}
+
+decompose :: (Decompose f v) => Term f -> DecompTerm f v
+decompose (Term t) = decomp t
diff --git a/src/Data/Comp/DeepSeq.hs b/src/Data/Comp/DeepSeq.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/DeepSeq.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances, TypeOperators,
+  TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.DeepSeq
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines full evaluation of signatures, which lifts to full
+-- evaluation of terms and contexts.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.DeepSeq
+    (
+     NFDataF(..),
+     rnfF'
+    )
+    where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Control.DeepSeq
+import Data.Comp.Derive
+import Data.Foldable
+import Prelude hiding (foldr)
+
+{-| Fully evaluate a value over a foldable signature. -}
+rnfF' :: (Foldable f, NFDataF f, NFData a) => f a -> ()
+rnfF' x = foldr seq (rnfF x) x
+
+instance (NFDataF f, NFData a) => NFData (Cxt h f a) where
+    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, ''[], ''(,)])
diff --git a/src/Data/Comp/Derive.hs b/src/Data/Comp/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive.hs
@@ -0,0 +1,108 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.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 'Functor',
+-- 'Foldable', and 'Traversable'.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive
+    (
+     derive,
+     -- * First-order Signatures
+     -- |Derive boilerplate instances for first-order signatures, i.e.
+     -- signatures for ordinary compositional data types.
+
+     -- ** ShowF
+     module Data.Comp.Derive.Show,
+     -- ** EqF
+     module Data.Comp.Derive.Equality,
+     -- ** OrdF
+     module Data.Comp.Derive.Ordering,
+     -- ** Functor
+     Functor,
+     instanceFunctor,
+     -- ** Foldable
+     module Data.Comp.Derive.Foldable,
+     -- ** Traversable
+     module Data.Comp.Derive.Traversable,
+     -- ** ExpFunctor
+     module Data.Comp.Derive.ExpFunctor,
+     -- ** Arbitrary
+     module Data.Comp.Derive.Arbitrary,
+     NFData(..),
+     instanceNFData,
+     -- ** 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,
+     -- ** HExpFunctor
+     module Data.Comp.Derive.Multi.ExpFunctor,
+     -- ** Smart Constructors
+     module Data.Comp.Derive.Multi.SmartConstructors
+    ) where
+
+import Control.DeepSeq (NFData(..))
+import Data.Comp.Derive.Foldable
+import Data.Comp.Derive.Traversable
+import Data.Comp.Derive.ExpFunctor
+import Data.Comp.Derive.DeepSeq
+import Data.Comp.Derive.Show
+import Data.Comp.Derive.Ordering
+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.ExpFunctor
+import Data.Comp.Derive.Multi.SmartConstructors
+
+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]
+
+{-| 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
+
+{-| Derive an instance of 'NFData' for a type constructor. -}
+instanceNFData :: Name -> Q [Dec]
+instanceNFData = D.derive makeNFData
diff --git a/src/Data/Comp/Derive/Arbitrary.hs b/src/Data/Comp/Derive/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Arbitrary.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE GADTs, TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Arbitrary
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @ArbitraryF@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Arbitrary
+    (
+     ArbitraryF(..),
+     instanceArbitraryF,
+     Arbitrary(..),
+     instanceArbitrary
+    )where
+
+import Test.QuickCheck
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH
+import Data.DeriveTH
+
+{-| Derive an instance of 'Arbitrary' for a type constructor. -}
+instanceArbitrary :: Name -> Q [Dec]
+instanceArbitrary = derive makeArbitrary
+
+{-| Signature arbitration. An instance @ArbitraryF f@ gives rise to an instance
+  @Arbitrary (Term f)@. -}
+class ArbitraryF f where
+    arbitraryF' :: Arbitrary v => [(Int,Gen (f v))]
+    arbitraryF' = [(1,arbitraryF)]
+    arbitraryF :: Arbitrary v => Gen (f v)
+    arbitraryF = frequency arbitraryF'
+    shrinkF :: Arbitrary v => f v -> [f v]
+    shrinkF _ = []
+
+{-| Derive an instance of 'ArbitraryF' for a type constructor of any
+  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
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt
+  let argNames = (map (VarT . tyVarBndrName) (tail args))
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (ClassP ''Arbitrary . (: [])) argNames
+      classType = AppT (ConT ''ArbitraryF) complType
+  arbitraryDecl <- generateArbitraryFDecl constrs
+  shrinkDecl <- generateShrinkFDecl constrs
+  return [InstanceD preCond classType [arbitraryDecl, shrinkDecl]]
+
+{-|
+  This function generates a declaration of the method 'arbitrary' for the given
+  list of constructors using 'generateGenDecl'.
+-}
+generateArbitraryFDecl :: [Con] -> Q Dec
+generateArbitraryFDecl = generateGenDecl 'arbitraryF'
+
+{-|
+  This function generates a declaration of a generator having the given name using
+  the given constructors, i.e., something like this:
+  
+  @
+  \<name\> :: Gen \<type\>
+  \<name\> = ...
+  @
+
+  where @\<type\>@ is the type of the given constructors. If the constructors do not belong
+  to the same type this function fails. The generated function will generate only elements of
+  this type using the given constructors. All argument types of these constructors are supposed
+  to be instances of 'Arbitrary'.
+-}
+
+generateGenDecl :: Name -> [Con] -> Q Dec
+generateGenDecl genName constrs
+    = do genBody <- listE $ map (addNum . constrGen . abstractConType) constrs
+         let genClause = Clause [] (NormalB genBody) []
+         return $ FunD genName [genClause]
+    where addNum e = [| (1,$e) |]
+          constrGen :: (Name,Int) -> ExpQ
+          constrGen (constr, n)
+              = do varNs <- newNames n "x"
+                   newSizeN <- newName "newSize"
+                   let newSizeE = varE newSizeN
+                   let newSizeP = varP newSizeN
+                   let constrsE = litE . IntegerL . toInteger $ n
+                   let binds = (`map` varNs) (\var -> bindS
+                                                     (varP var)
+                                                     [| resize $newSizeE arbitrary |] )
+                   let apps =  appsE (conE constr: map varE varNs)
+                   let build = doE $
+                               binds ++
+                               [noBindS [|return $apps|]]
+                   if n == 0 
+                      then [|return $apps|]
+                      else  [| sized $ \ size ->
+                                 $(letE [valD 
+                                         newSizeP
+                                         (normalB [|((size - 1) `div` $constrsE ) `max` 0|])
+                                         [] ]
+                                   build) |]
+
+{-|
+  This function generates a declaration for the method 'shrink' using the given constructors.
+  The constructors are supposed to belong to the same type.
+-}
+generateShrinkFDecl :: [Con] -> Q Dec
+generateShrinkFDecl constrs
+    = let clauses = map (generateClause.abstractConType) constrs
+      in funD 'shrink clauses
+  where generateClause (constr, n)
+            = do varNs <- newNames n "x"
+                 resVarNs <- newNames n "x'"
+                 binds <- mapM (\(var,resVar) -> bindS (varP resVar) [| $(varE var) : shrink $(varE var) |]) $ zip varNs resVarNs
+                 let ret = NoBindS $ AppE (VarE 'return) (foldl1 AppE ( ConE constr: map VarE resVarNs ))
+                     stmtSeq = binds ++ [ret]
+                     pat = ConP constr $ map VarP varNs
+                 return $ Clause [pat] (NormalB $ AppE (VarE 'tail) (DoE stmtSeq)) []
diff --git a/src/Data/Comp/Derive/DeepSeq.hs b/src/Data/Comp/Derive/DeepSeq.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/DeepSeq.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.DeepSeq
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @DeepSeq@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.DeepSeq
+    (
+     NFDataF(..),
+     instanceNFDataF
+    ) where
+
+
+import Control.DeepSeq
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH
+import Data.Maybe
+
+{-| Signature normal form. An instance @NFDataF f@ gives rise to an instance
+  @NFData (Term f)@. -}
+class NFDataF f where
+    rnfF :: NFData a => f a -> ()
+
+{-| 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
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let fArg = VarT . tyVarBndrName $ last args
+      argNames = (map (VarT . tyVarBndrName) (init args))
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (ClassP ''NFData . (: [])) argNames
+      classType = AppT (ConT ''NFDataF) complType
+  constrs' <- mapM normalConExp constrs
+  rnfFDecl <- funD 'rnfF (rnfFClauses fArg constrs')
+  return [InstanceD preCond classType [rnfFDecl]]
+      where rnfFClauses fArg = map (genRnfFClause fArg)
+            filterFarg excl x
+                | excl = Nothing
+                | otherwise = Just $ varE x
+            mkPat True _ = WildP
+            mkPat False x = VarP x
+            genRnfFClause fArg (constr, args) = do 
+              let isFargs = map (==fArg) args
+                  n = length args
+              varNs <- newNames n "x"
+              let pat = ConP constr $ zipWith mkPat isFargs varNs
+                  allVars = catMaybes $ zipWith filterFarg isFargs varNs
+              body <- foldr (\ x y -> [|rnf $x `seq` $y|]) [| () |] allVars
+              return $ Clause [pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Equality.hs b/src/Data/Comp/Derive/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Equality.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Equality
+-- 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 @EqF@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Derive.Equality
+    (
+     EqF(..),
+     instanceEqF
+    ) where
+
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH hiding (Cxt, match)
+
+
+{-| Signature equality. An instance @EqF f@ gives rise to an instance
+  @Eq (Term f)@. -}
+class EqF f where
+
+    eqF :: Eq a => f a -> f a -> Bool
+
+{-| 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
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let argNames = (map (VarT . tyVarBndrName) (init args))
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (ClassP ''Eq . (: [])) argNames
+      classType = AppT (ConT ''EqF) complType
+  eqFDecl <- funD 'eqF  (eqFClauses constrs)
+  return [InstanceD preCond classType [eqFDecl]]
+      where eqFClauses constrs = map (genEqClause.abstractConType) constrs
+                                   ++ defEqClause constrs
+            filterFarg fArg ty x = (fArg == ty, x)
+            defEqClause constrs
+                | length constrs  < 2 = []
+                | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]
+            genEqClause (constr, n) = do 
+              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 x y = let (x',y') = (return x,return y)
+                             in [| $x' == $y'|]
+                  eqs = listE $ zipWith mkEq vars vars'
+              body <- if n == 0 
+                      then [|True|]
+                      else [|and $eqs|]
+              return $ Clause [pat, pat'] (NormalB body) []
diff --git a/src/Data/Comp/Derive/ExpFunctor.hs b/src/Data/Comp/Derive/ExpFunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/ExpFunctor.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.ExpFunctor
+-- Copyright   :  (c) 2011 Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @ExpFunctor@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.ExpFunctor
+    (
+     ExpFunctor,
+     instanceExpFunctor
+    ) where
+
+import Data.Comp.ExpFunctor
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH
+
+{-| Derive an instance of 'ExpFunctor' for a type constructor of any first-order
+  kind taking at least one argument. -}
+instanceExpFunctor :: Name -> Q [Dec]
+instanceExpFunctor fname = do
+  -- Comments below apply to the example where name = T, args = [a,b], and
+  -- constrs = [(X,[a]), (Y,[a,b]), (Z,[b -> b])], i.e. the data type
+  -- declaration: T a b = X a | Y a b | Z (b -> b)
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  -- fArg = b
+  let fArg :: Name = tyVarBndrName $ last args
+  -- argNames = [a]
+  let argNames = map (VarT . tyVarBndrName) (init args)
+  -- compType = T a
+  let complType = foldl AppT (ConT name) argNames
+  -- classType = ExpFunctor (T a)
+  let classType = AppT (ConT ''ExpFunctor) complType
+  -- constrs' = [(X,[a]), (Y,[a,b]), (Z,[b -> b])]
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  xmapDecl <- funD 'xmap (map (xmapClause fArg) constrs')
+  return [InstanceD [] classType [xmapDecl]]
+      where xmapClause :: Name -> (Name,[Type]) -> ClauseQ
+            xmapClause fArg (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 <- xmapArgs fArg f g (zip varNs args) (conE constr)
+              return $ Clause [fp, gp, pat] (NormalB body) []
+            xmapArgs :: Name -> ExpQ -> ExpQ -> [(Name, Type)] -> ExpQ -> ExpQ
+            xmapArgs _ _ _ [] acc =
+                acc
+            xmapArgs fArg f g ((x,tp):tps) acc =
+                xmapArgs fArg f g tps (acc `appE`
+                                       (xmapArg fArg tp f g `appE` varE x))
+            -- Given the name of the functor variable, a type, and the two
+            -- arguments to xmap, return the expression that should be applied
+            -- to the parameter of the given type.
+            -- Example: xmapArg b (b -> b) f g yields the expression
+            -- [|\x -> f . x . g|]
+            xmapArg :: Name -> Type -> ExpQ -> ExpQ -> ExpQ
+            xmapArg fArg tp f g =
+                -- No need to descend into tp if it does not contain the functor
+                -- type variable
+                if not $ containsType tp (VarT fArg) then
+                    [|id|]
+                else
+                    case tp of
+                      ForallT vars _ tp' ->
+                          -- Check if the functor variable has been rebound
+                          if any ((==) fArg . tyVarBndrName) vars then
+                              [|id|]
+                          else
+                              xmapArg fArg tp' f g
+                      VarT a ->
+                          -- Apply f if we have reached the functor variable
+                          if a == fArg then f else [|id|]
+                      ConT _ ->
+                          [|id|]
+                      AppT (AppT ArrowT tp1) tp2 -> do
+                          -- Note that f and g are swapped in the contravariant
+                          -- type tp1
+                          xn <- newName "x"
+                          let ftp1 = xmapArg fArg tp1 g f
+                          let ftp2 = xmapArg fArg tp2 f g
+                          lamE [varP xn]
+                               (infixE (Just ftp2)
+                                       [|(.)|]
+                                       (Just $ infixE (Just $ varE xn)
+                                                      [|(.)|]
+                                                      (Just ftp1)))
+                      AppT _ tp' ->
+                          [|fmap|] `appE` xmapArg fArg tp' f g
+                      SigT tp' _ ->
+                          xmapArg fArg tp' f g
+                      _ ->
+                          error $ "unsopported type: " ++ show tp
diff --git a/src/Data/Comp/Derive/Foldable.hs b/src/Data/Comp/Derive/Foldable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Foldable.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Foldable
+-- 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 @Foldable@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Foldable
+    (
+     Foldable,
+     instanceFoldable
+    ) where
+
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH
+import Data.Foldable
+import Control.Monad
+import Data.Monoid
+import Data.Maybe
+import qualified Prelude as P (foldl,foldr,foldl1,foldr1)
+import Prelude hiding  (foldl,foldr,foldl1,foldr1)
+
+
+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 'Foldable' for a type constructor of any first-order
+  kind taking at least one argument. -}
+instanceFoldable :: Name -> Q [Dec]
+instanceFoldable fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let fArg = VarT . tyVarBndrName $ last args
+      argNames = (map (VarT . tyVarBndrName) (init args))
+      complType = foldl AppT (ConT name) argNames
+      classType = AppT (ConT ''Foldable) complType
+  constrs' <- mapM (mkPatAndVars  . isFarg fArg <=< normalConExp) constrs
+  foldDecl <- funD 'fold (map foldClause constrs')
+  foldMapDecl <- funD 'foldMap (map foldMapClause constrs')
+  foldlDecl <- funD 'foldl (map foldlClause constrs')
+  foldrDecl <- funD 'foldr (map foldrClause constrs')
+  foldl1Decl <- funD 'foldl1 (map foldl1Clause constrs')
+  foldr1Decl <- funD 'foldr1 (map foldr1Clause constrs')
+  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl,foldl1Decl,foldr1Decl]]
+      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 body <- if null vars
+                           then [|mempty|]
+                           else P.foldl1 (\ x y -> [|$x `mappend` $y|])
+                                    $ map (\(d,x) -> iter' d [|fold|] x) 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) []
+            foldl1Clause (pat,vars) =
+                do fn <- newName "f"
+                   let f = varE fn
+                       fp = case vars of
+                              (d,_):r
+                                  | d > 0 || not (null r) -> VarP fn                              
+                              _ -> WildP 
+                       mkComp (d,x) = iter' d [|foldl1 $f|] x
+                   body <- case vars of 
+                             [] -> [|undefined|] 
+                             _ -> P.foldl1 (\ x y -> [|$f $x $y|]) $ map mkComp vars
+                   return $ Clause [fp, pat] (NormalB body) []
+            foldr1Clause (pat,vars) =
+                do fn <- newName "f"
+                   let f = varE fn
+                       fp = case vars of
+                              (d,_):r
+                                  | d > 0 || not (null r) -> VarP fn                              
+                              _ -> WildP 
+                       mkComp (d,x) = iter' d [|foldr1 $f|] x
+                   body <- case vars of 
+                             [] -> [|undefined|] 
+                             _ -> P.foldr1 (\ x y -> [|$f $x $y|]) $ map mkComp vars
+                   return $ Clause [fp, pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Multi/Equality.hs b/src/Data/Comp/Derive/Multi/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/Equality.hs
@@ -0,0 +1,81 @@
+{-# 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/ExpFunctor.hs b/src/Data/Comp/Derive/Multi/ExpFunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/ExpFunctor.hs
@@ -0,0 +1,94 @@
+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Multi.ExpFunctor
+-- Copyright   :  (c) 2011 Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive instances of @HExpFunctor@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Multi.ExpFunctor
+    (
+     HExpFunctor,
+     instanceHExpFunctor
+    ) where
+
+import Data.Comp.Multi.ExpFunctor
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH
+
+{-| Derive an instance of 'HExpFunctor' for a type constructor of any 
+ higher-order kind taking at least two arguments. -}
+instanceHExpFunctor :: Name -> Q [Dec]
+instanceHExpFunctor fname = do
+  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname
+  let args' = init args
+  let fArg :: Name = tyVarBndrName $ last args'
+  let argNames = map (VarT . tyVarBndrName) (init args')
+  let complType = foldl AppT (ConT name) argNames
+  let classType = AppT (ConT ''HExpFunctor) complType
+  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs
+  hxmapDecl <- funD 'hxmap (map (hxmapClause fArg) constrs')
+  return [InstanceD [] classType [hxmapDecl]]
+      where hxmapClause :: Name -> (Name,[Type]) -> ClauseQ
+            hxmapClause fArg (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 <- hxmapArgs fArg f g (zip varNs args) (conE constr)
+              return $ Clause [fp, gp, pat] (NormalB body) []
+            hxmapArgs :: Name -> ExpQ -> ExpQ -> [(Name, Type)] -> ExpQ -> ExpQ
+            hxmapArgs _ _ _ [] acc =
+                acc
+            hxmapArgs fArg f g ((x,tp):tps) acc =
+                hxmapArgs fArg f g tps (acc `appE`
+                                       (hxmapArg fArg tp f g `appE` varE x))
+            hxmapArg :: Name -> Type -> ExpQ -> ExpQ -> ExpQ
+            hxmapArg fArg tp f g =
+                -- No need to descend into tp if it does not contain the 
+                -- higher-order functor type variable
+                if not $ containsType tp (VarT fArg) then
+                    [|id|]
+                else
+                    case tp of
+                      ForallT vars _ tp' ->
+                          -- Check if the variable has been rebound
+                          if any ((==) fArg . tyVarBndrName) vars then
+                              [|id|]
+                          else
+                              hxmapArg fArg tp' f g
+                      (AppT (VarT a) _) ->
+                          -- Apply f if we have reached the higher-order functor
+                          -- variable
+                          if a == fArg then f else [|id|]
+                      ConT _ ->
+                          [|id|]
+                      AppT (AppT ArrowT tp1) tp2 -> do
+                          -- Note that f and g are swapped in the contravariant
+                          -- type tp1
+                          xn <- newName "x"
+                          let ftp1 = hxmapArg fArg tp1 g f
+                          let ftp2 = hxmapArg fArg tp2 f g
+                          lamE [varP xn]
+                               (infixE (Just ftp2)
+                                       [|(.)|]
+                                       (Just $ infixE (Just $ varE xn)
+                                                      [|(.)|]
+                                                      (Just ftp1)))
+                      AppT _ tp' ->
+                          [|fmap|] `appE` hxmapArg fArg tp' f g
+                      SigT tp' _ ->
+                          hxmapArg fArg tp' f g
+                      _ ->
+                          error $ "unsopported type: " ++ show tp
diff --git a/src/Data/Comp/Derive/Multi/Foldable.hs b/src/Data/Comp/Derive/Multi/Foldable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/Foldable.hs
@@ -0,0 +1,119 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/Functor.hs
@@ -0,0 +1,63 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/Show.hs
@@ -0,0 +1,69 @@
+{-# 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 :: HAlg 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/SmartConstructors.hs
@@ -0,0 +1,61 @@
+{-# 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
+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 'hinject' 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 [|hinject $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 ''HCxt) [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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Multi/Traversable.hs
@@ -0,0 +1,83 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Ordering.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Ordering
+-- 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 @OrdF@.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Derive.Ordering
+    (
+     OrdF(..),
+     instanceOrdF
+    ) where
+
+import Data.Comp.Derive.Equality
+import Data.Comp.Derive.Utils
+
+import Data.Maybe
+import Data.List
+import Language.Haskell.TH hiding (Cxt)
+
+{-| Signature ordering. An instance @OrdF f@ gives rise to an instance
+  @Ord (Term f)@. -}
+class EqF f => OrdF f where
+    compareF :: Ord a => f a -> f a -> Ordering
+
+    
+compList :: [Ordering] -> Ordering
+compList = fromMaybe EQ . find (/= EQ)
+
+{-| 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
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let argNames = (map (VarT . tyVarBndrName) (init args))
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (ClassP ''Ord . (: [])) argNames
+      classType = AppT (ConT ''OrdF) complType
+  eqAlgDecl <- funD 'compareF  (compareFClauses constrs)
+  return [InstanceD preCond classType [eqAlgDecl]]
+      where compareFClauses [] = []
+            compareFClauses constrs = 
+                let constrs' = map abstractConType constrs `zip` [1..]
+                    constPairs = [(x,y)| x<-constrs', y <- constrs']
+                in map genClause constPairs
+            genClause ((c,n),(d,m))
+                | n == m = genEqClause c
+                | n < m = genLtClause c d
+                | otherwise = genGtClause c d
+            genEqClause (constr, n) = do 
+              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 x y = let (x',y') = (return x,return y)
+                             in [| compare $x' $y'|]
+                  eqs = listE $ zipWith mkEq vars vars'
+              body <- [|compList $eqs|]
+              return $ Clause [pat, pat'] (NormalB body) []
+            genLtClause (c, _) (d, _) = clause [recP c [], recP d []] (normalB [| LT |]) []
+            genGtClause (c, _) (d, _) = clause [recP c [], recP d []] (normalB [| GT |]) []
diff --git a/src/Data/Comp/Derive/Show.hs b/src/Data/Comp/Derive/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Show.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Show
+-- 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 @ShowF@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Show
+    (
+     ShowF(..),
+     instanceShowF
+    ) where
+
+import Data.Comp.Derive.Utils
+import Language.Haskell.TH
+
+{-| Signature printing. An instance @ShowF f@ gives rise to an instance
+  @Show (Term f)@. -}
+class ShowF f where
+    showF :: f String -> String
+             
+showConstr :: String -> [String] -> String
+showConstr con [] = con
+showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"
+
+{-| 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
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let 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 ''ShowF) complType
+  constrs' <- mapM normalConExp constrs
+  showFDecl <- funD 'showF (showFClauses fArg constrs')
+  return [InstanceD preCond classType [showFDecl]]
+      where showFClauses fArg = map (genShowFClause fArg)
+            filterFarg fArg ty x = (fArg == ty, varE x)
+            mkShow (isFArg, var)
+                | isFArg = 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 <- [|showConstr conName $shows|]
+              return $ Clause [pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/SmartConstructors.hs b/src/Data/Comp/Derive/SmartConstructors.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/SmartConstructors.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Signature
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- Automatically derive smart constructors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.SmartConstructors 
+    (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
+ taking at least one argument. 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
+                fvar <- newName "f"
+                hvar <- newName "h"
+                avar <- newName "a"
+                let targs' = init targs
+                    vars = fvar:hvar:avar:targs'
+                    f = varT fvar
+                    h = varT hvar
+                    a = varT avar
+                    ftype = foldl appT (conT tname) (map varT targs')
+                    constr = classP ''(:<:) [ftype, f]
+                    typ = foldl appT (conT ''Cxt) [h, f, a]
+                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ
+                sigD sname typeSig
+              genSig _ _ _ _ = []
diff --git a/src/Data/Comp/Derive/Traversable.hs b/src/Data/Comp/Derive/Traversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Traversable.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Traversable
+-- 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 @Traversable@.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Derive.Traversable
+    (
+     Traversable,
+     instanceTraversable
+    ) where
+
+import Data.Comp.Derive.Utils
+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 'Traversable' for a type constructor of any
+  first-order kind taking at least one argument. -}
+instanceTraversable :: Name -> Q [Dec]
+instanceTraversable fname = do
+  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let fArg = VarT . tyVarBndrName $ last args
+      argNames = (map (VarT . tyVarBndrName) (init args))
+      complType = foldl AppT (ConT name) argNames
+      classType = AppT (ConT ''Traversable) complType
+  constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs
+  traverseDecl <- funD 'traverse (map traverseClause constrs')
+  sequenceADecl <- funD 'sequenceA (map sequenceAClause constrs')
+  mapMDecl <- funD 'mapM (map mapMClause constrs')
+  sequenceDecl <- funD 'sequence (map sequenceClause constrs')
+  return [InstanceD [] classType [traverseDecl, sequenceADecl, mapMDecl,sequenceDecl]]
+      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) []
+            sequenceAClause (con, pat,vars',hasFargs,_,_) =
+                do let vars = vars' (\d x -> iter' d [|sequenceA|] x) (\x -> [|pure $x|])
+                   body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars
+                   return $ Clause [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) []
+            sequenceClause (con, pat,_,hasFargs,allVars, fvars) =
+                do let conAp = P.foldl appE con allVars
+                       conBind (d, x) y = [| $(iter' d [|sequence|] (varE x))  >>= $(lamE [varP x] y)|]
+                   body <- P.foldr conBind [|return $conAp|] fvars
+                   return $ Clause [pat] (NormalB body) []
diff --git a/src/Data/Comp/Derive/Utils.hs b/src/Data/Comp/Derive/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Derive/Utils.hs
@@ -0,0 +1,101 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Derive.Utils
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines some utility functions for deriving instances
+-- for functor based type classes.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Derive.Utils where
+
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Control.Monad
+import Language.Haskell.TH.ExpandSyns
+
+{-|
+  This is the @Q@-lifted version of 'abstractNewtypeQ.
+-}
+abstractNewtypeQ :: Q Info -> Q Info
+abstractNewtypeQ = liftM abstractNewtype
+
+{-|
+  This function abstracts away @newtype@ declaration, it turns them into
+  @data@ declarations.
+-}
+abstractNewtype :: Info -> Info
+abstractNewtype (TyConI (NewtypeD cxt name args constr derive))
+    = TyConI (DataD cxt name args [constr] derive)
+abstractNewtype owise = owise
+
+{-|
+  This function provides the name and the arity of the given data constructor.
+-}
+normalCon :: Con -> (Name,[StrictType])
+normalCon (NormalC constr args) = (constr, args)
+normalCon (RecC constr args) = (constr, map (\(_,s,t) -> (s,t)) args)
+normalCon (InfixC a constr b) = (constr, [a,b])
+normalCon (ForallC _ _ constr) = normalCon constr
+
+
+normalCon' :: Con -> (Name,[Type])
+normalCon' = fmap (map snd) . normalCon 
+
+-- | Same as normalCon' but expands type synonyms.
+normalConExp :: Con -> Q (Name,[Type])
+normalConExp c = do 
+  let (n,ts) = normalCon' c
+  ts' <- mapM expandSyns ts
+  return (n, ts')
+
+{-|
+  This function provides the name and the arity of the given data constructor.
+-}
+abstractConType :: Con -> (Name,Int)
+abstractConType (NormalC constr args) = (constr, length args)
+abstractConType (RecC constr args) = (constr, length args)
+abstractConType (InfixC _ constr _) = (constr, 2)
+abstractConType (ForallC _ _ constr) = abstractConType constr
+
+{-|
+  This function returns the name of a bound type variable
+-}
+tyVarBndrName (PlainTV n) = n
+tyVarBndrName (KindedTV n _) = n
+
+containsType :: Type -> Type -> Bool
+containsType s t
+             | s == t = True
+             | otherwise = case s of
+                             ForallT _ _ s' -> containsType s' t
+                             AppT s1 s2 -> containsType s1 t || containsType s2 t
+                             SigT s' _ -> containsType s' t
+                             _ -> False
+
+containsType' :: Type -> Type -> [Int]
+containsType' = run 0
+    where run n s t
+             | s == t = [n]
+             | otherwise = case s of
+                             ForallT _ _ s' -> run n s' t
+                             -- only going through the right-hand side counts!
+                             AppT s1 s2 -> run n s1 t ++ run (n+1) s2 t
+                             SigT s' _ -> run n s' t
+                             _ -> []
+
+
+{-|
+  This function provides a list (of the given length) of new names based
+  on the given string.
+-}
+newNames :: Int -> String -> Q [Name]
+newNames n name = replicateM n (newName name)
+
+tupleTypes n m = map tupleTypeName [n..m]
+
diff --git a/src/Data/Comp/Equality.hs b/src/Data/Comp/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Equality.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Equality
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines equality for signatures, which lifts to equality for
+-- terms and contexts.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Equality
+    (
+     EqF(..),
+     eqMod,
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Derive
+import Data.Comp.Derive.Utils
+
+import Data.Foldable
+
+import Control.Monad hiding (mapM_)
+import Prelude hiding (mapM_, all)
+
+
+
+-- instance (EqF f, Eq p) => EqF (f :*: p) where
+--    eqF (v1 :*: p1) (v2 :*: p2) = p1 == p2 && v1 `eqF` v2
+
+{-|
+  'EqF' is propagated through sums.
+-}
+
+instance (EqF f, EqF g) => EqF (f :+: g) where
+    eqF (Inl x) (Inl y) = eqF x y
+    eqF (Inr x) (Inr y) = eqF x y
+    eqF _ _ = False
+
+{-|
+  From an 'EqF' functor an 'Eq' instance of the corresponding
+  term type can be derived.
+-}
+instance (EqF f) => EqF (Cxt h f) where
+
+    eqF (Term e1) (Term e2) = e1 `eqF` e2
+    eqF (Hole h1) (Hole h2) = h1 == h2
+    eqF _ _ = False
+
+instance (EqF f, Eq a)  => Eq (Cxt h f a) where
+    (==) = eqF
+
+instance EqF [] where
+    eqF = (==)
+
+{-| This function implements equality of values of type @f a@ modulo
+the equality of @a@ itself. If two functorial values are equal in this
+sense, 'eqMod' returns a 'Just' value containing a list of pairs
+consisting of corresponding components of the two functorial
+values. -}
+
+eqMod :: (EqF f, Functor f, Foldable f) => f a -> f b -> Maybe [(a,b)]
+eqMod s t
+    | unit s `eqF` unit' t = Just args
+    | otherwise = Nothing
+    where unit = fmap (const ())
+          unit' = fmap (const ())
+          args = toList s `zip` toList t
+
+$(derive [instanceEqF] $ (''Maybe) : tupleTypes 2 10)
diff --git a/src/Data/Comp/ExpFunctor.hs b/src/Data/Comp/ExpFunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/ExpFunctor.hs
@@ -0,0 +1,21 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module	: Data.Comp.ExpFunctor
+-- Copyright 	: 2008 Edward Kmett
+-- License	: BSD
+--
+-- Maintainer	: Tom Hvitved <hvitved@diku.dk>
+-- Stability	: unknown
+-- Portability	: unknown
+--
+-- Exponential functors, see <http://comonad.com/reader/2008/rotten-bananas/>.
+--------------------------------------------------------------------------------
+
+module Data.Comp.ExpFunctor
+    ( ExpFunctor(..)
+    ) where
+
+{-| Exponential functors are functors that may be both covariant (as ordinary
+ functors) and contravariant. -}
+class ExpFunctor f where
+    xmap :: (a -> b) -> (b -> a) -> f a -> f b
diff --git a/src/Data/Comp/Generic.hs b/src/Data/Comp/Generic.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Generic.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE GADTs, ScopedTypeVariables #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.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.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Generic where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Foldable
+import Data.Maybe
+import Data.Traversable
+import GHC.Exts
+import Control.Monad hiding (mapM)
+import Prelude hiding (foldl,mapM)
+
+-- | This function returns a list of all subterms of the given
+-- term. This function is similar to Uniplate's @universe@ function.
+subterms :: forall f . Foldable f => Term f -> [Term f]
+subterms t = build (f t)
+    where f :: Term f -> (Term f -> b -> b) -> b -> b
+          f t cons nil = t `cons` foldl (\u s -> f s cons u) nil (unTerm t)
+-- universe t = t : foldl (\u s -> u ++ universe s) [] (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 . (Foldable f, g :<: f) => Term f -> [g (Term f)]
+subterms' (Term t) = build (f t)
+    where f :: f (Term f) -> (g (Term f) -> b -> b) -> b -> b
+          f t cons nil = let rest = foldl (\u (Term s) -> f s cons u) nil t
+                         in case proj t of
+                              Just t' -> 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 :: (Functor f) => (Term f -> Term f) -> Term f -> Term f
+transform f = run
+    where run = f . Term . fmap run . unTerm
+-- transform f  = f . Term . fmap (transform f) . unTerm
+
+transform' :: (Functor f) => (Term f -> Maybe (Term f)) -> Term f -> Term f
+transform' f = transform f' where
+    f' t = fromMaybe t (f t)
+
+
+-- | Monadic version of 'transform'.
+transformM :: (Traversable f, Monad m) =>
+             (Term f -> m (Term f)) -> Term f -> m (Term f)
+transformM  f = run 
+    where run t = f =<< liftM Term (mapM run $ unTerm t)
+
+query :: Foldable 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) = foldl (\s x -> s `c` query q c x) (q i) t
+
+gsize :: Foldable f => Term f -> Int
+gsize = query (const 1) (+)
+
+-- | This function computes the generic size of the given term,
+-- i.e. the its number of subterm occurrences.
+size :: Foldable f => Cxt h f a -> Int
+size (Hole {}) = 0
+size (Term t) = foldl (\s x -> s + size x) 1 t
+
+-- | This function computes the generic depth of the given term.
+depth :: Foldable f => Cxt h f a -> Int
+depth (Hole {}) = 0
+depth (Term t) = 1 + foldl (\s x -> s + size x) 0 t
diff --git a/src/Data/Comp/Matching.hs b/src/Data/Comp/Matching.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Matching.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE GADTs, FlexibleContexts #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Matching
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module implements matching of contexts or terms with variables againts terms
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Matching
+    (
+     matchCxt,
+     matchTerm,
+     module Data.Comp.Variables
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Equality
+import Data.Comp.Variables
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Foldable
+
+import Prelude hiding (mapM_, all)
+
+{-| This is an auxiliary function for implementing 'matchCxt'. It behaves
+similarly as 'match' but is oblivious to non-linearity. Therefore, the
+substitution that is returned maps holes to non-empty lists of terms
+(resp. contexts in general). This substitution is only a matching
+substitution if all elements in each list of the substitution's range
+are equal. -}
+
+matchCxt' :: (Ord v, EqF f, Functor f, Foldable f)
+       => Context f v -> Cxt h f a -> Maybe (Map v [Cxt h f a])
+matchCxt' (Hole v) t = Just $  Map.singleton v [t]
+matchCxt' (Term s) (Term t) = do
+  eqs <- eqMod s t
+  substs <- mapM (uncurry matchCxt') eqs
+  return $ Map.unionsWith (++) substs
+matchCxt' Term {} Hole {} = Nothing
+
+
+{-| This function takes a context @c@ as the first argument and tries
+to match it against the term @t@ (or in general a context with holes
+in @a@). The context @c@ matches the term @t@ if there is a
+/matching substitution/ @s@ that maps holes to terms (resp. contexts in general)
+such that if the holes in the context @c@ are replaced according to
+the substitution @s@, the term @t@ is obtained. Note that the context
+@c@ might be non-linear, i.e. has multiple holes that are
+equal. According to the above definition this means that holes with
+equal holes have to be instantiated by equal terms! -}
+
+matchCxt :: (Ord v,EqF f, Eq (Cxt h f a), Functor f, Foldable f)
+         => Context f v -> Cxt h f a -> Maybe (CxtSubst h a f v)
+matchCxt c1 c2 = do 
+  res <- matchCxt' c1 c2
+  let insts = Map.elems res
+  mapM_ checkEq insts
+  return $ Map.map head res
+    where checkEq [] = Nothing
+          checkEq (c : cs)
+              | all (== c) cs = Just ()
+              | otherwise = Nothing
+
+{-| This function is similar to 'matchCxt' but instead of a context it
+matches a term with variables against a context.  -}
+
+matchTerm :: (Ord v, EqF f, Eq (Cxt h f a) , Functor f, Foldable f, HasVars f v)
+          => Term f -> Cxt h f a -> Maybe (CxtSubst h a f v)
+matchTerm t = matchCxt (varsToHoles t)
+
diff --git a/src/Data/Comp/Multi.hs b/src/Data/Comp/Multi.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi.hs
@@ -0,0 +1,456 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@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.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Multi (
+  -- * Examples
+  -- ** Pure Computations
+  -- $ex1
+
+  -- ** Monadic Computations
+  -- $ex2
+
+  -- ** Composing Term Homomorphisms and Algebras
+  -- $ex3
+
+  -- ** Lifting Term Homomorphisms to Products
+  -- $ex4
+
+  -- ** Higher-Order Abstract Syntax
+  -- $ex5
+    module Data.Comp.Multi.Term
+  , module Data.Comp.Multi.Algebra
+  , module Data.Comp.Multi.Functor
+  , module Data.Comp.Multi.Sum
+  , module Data.Comp.Multi.Product
+    ) where
+
+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
+
+{- $ex1
+The example below 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.
+
+> import Data.Comp.Multi
+> import Data.Comp.Multi.Show ()
+> import Data.Comp.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 [instanceHFunctor, instanceHShowF, smartHConstructors] 
+>          [''Value, ''Op])
+> 
+> -- 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
+> eval :: (HFunctor f, Eval f v) => HTerm f :-> HTerm v
+> eval = hcata 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
+> 
+> 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)
+> 
+> -- Example: evalEx = iConst 2
+> evalEx :: HTerm Value Int
+> evalEx = eval (iFst $ iPair (iConst 2) (iConst 1) :: HTerm Sig Int)
+-}
+
+{- $ex2
+The example below 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.
+
+> import Data.Comp.Multi
+> import Data.Comp.Multi.Show ()
+> import Data.Comp.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 [instanceHFunctor, instanceHTraversable, instanceHFoldable,
+>           instanceHEqF, instanceHShowF, smartHConstructors]
+>          [''Value, ''Op])
+> 
+> -- Monadic term evaluation algebra
+> class EvalM f v where
+>   evalAlgM :: HAlgM Maybe f (HTerm v)
+> 
+> instance (EvalM f v, EvalM g v) => EvalM (f :++: g) v where
+>   evalAlgM (HInl x) = evalAlgM x
+>   evalAlgM (HInr x) = evalAlgM x
+> 
+> evalM :: (HTraversable f, EvalM f v) => HTerm f l
+>                                      -> Maybe (HTerm v l)
+> evalM = hcataM evalAlgM
+> 
+> instance (Value :<<: v) => EvalM Value v where
+>   evalAlgM = return . hinject
+> 
+> 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) => HTerm v Int -> Maybe Int
+> projC v = case hproject v of
+>             Just (Const n) -> return n; _ -> Nothing
+> 
+> projP :: (Value :<<: v) => HTerm v (a,b) -> Maybe (HTerm v a, HTerm v b)
+> projP v = case hproject v of
+>             Just (Pair x y) -> return (x,y); _ -> Nothing
+> 
+> -- Example: evalMEx = Just (iConst 5)
+> evalMEx :: Maybe (HTerm Value Int)
+> evalMEx = evalM ((iConst 1) `iAdd`
+>                  (iConst 2 `iMult` iConst 2) :: HTerm Sig Int)
+-}
+
+{- $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@, @UndecidableInstances@, and @GADTs@. 
+Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.
+
+> import Data.Comp.Multi
+> import Data.Comp.Multi.Show ()
+> import Data.Comp.Derive
+> 
+> -- 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 [instanceHFunctor, instanceHTraversable, instanceHFoldable,
+>           instanceHEqF, instanceHShowF, smartHConstructors]
+>          [''Value, ''Op, ''Sugar])
+> 
+> -- Term homomorphism for desugaring of terms
+> class (HFunctor f, HFunctor g) => Desugar f g where
+>   desugHom :: HTermHom f g
+>   desugHom = desugHom' . hfmap HHole
+>   desugHom' :: HAlg f (HContext g a)
+>   desugHom' x = appHCxt (desugHom x)
+> 
+> instance (Desugar f h, Desugar g h) => Desugar (f :++: g) h where
+>   desugHom (HInl x) = desugHom x
+>   desugHom (HInr x) = desugHom x
+>   desugHom' (HInl x) = desugHom' x
+>   desugHom' (HInr x) = desugHom' x
+> 
+> instance (Value :<<: v, HFunctor v) => Desugar Value v where
+>   desugHom = simpHCxt . hinj
+> 
+> instance (Op :<<: v, HFunctor v) => Desugar Op v where
+>   desugHom = simpHCxt . hinj
+> 
+> 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 :: 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
+> 
+> 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
+>
+> 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)
+>
+> -- Compose the evaluation algebra and the desugaring homomorphism to an
+> -- algebra
+> eval :: HTerm Sig' :-> HTerm Value
+> eval = hcata (evalAlg `compHAlg` (desugHom :: HTermHom Sig' Sig))
+> 
+> -- Example: evalEx = iPair (iConst 2) (iConst 1)
+> evalEx :: HTerm Value (Int,Int)
+> 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@, @UndecidableInstances@, and @GADTs@.
+ Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.
+
+> import Data.Comp.Multi
+> import Data.Comp.Multi.Show ()
+> import Data.Comp.Derive
+> 
+> -- 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 [instanceHFunctor, instanceHTraversable, instanceHFoldable,
+>           instanceHEqF, instanceHShowF, smartHConstructors]
+>          [''Value, ''Op, ''Sugar])
+> 
+> -- Term homomorphism for desugaring of terms
+> class (HFunctor f, HFunctor g) => Desugar f g where
+>   desugHom :: HTermHom f g
+>   desugHom = desugHom' . hfmap HHole
+>   desugHom' :: HAlg f (HContext g a)
+>   desugHom' x = appHCxt (desugHom x)
+> 
+> instance (Desugar f h, Desugar g h) => Desugar (f :++: g) h where
+>   desugHom (HInl x) = desugHom x
+>   desugHom (HInr x) = desugHom x
+>   desugHom' (HInl x) = desugHom' x
+>   desugHom' (HInr x) = desugHom' x
+> 
+> instance (Value :<<: v, HFunctor v) => Desugar Value v where
+>   desugHom = simpHCxt . hinj
+> 
+> instance (Op :<<: v, HFunctor v) => Desugar Op v where
+>   desugHom = simpHCxt . hinj
+> 
+> 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 :: HTerm Sig' :-> HTerm Sig
+> desug = appHTermHom desugHom
+>
+> -- Example: desugEx = iPair (iConst 2) (iConst 1)
+> desugEx :: HTerm Sig (Int,Int)
+> desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)
+>
+> -- Lift desugaring to terms annotated with source positions
+> desugP :: HTerm SigP' :-> HTerm SigP
+> desugP = appHTermHom (productHTermHom desugHom)
+>
+> iSwapP :: (HDistProd f p f', Sugar :<<: f) => p -> HTerm f' (a,b) -> HTerm f' (b,a)
+> iSwapP p x = HTerm (hinjectP p $ hinj $ Swap x)
+>
+> iConstP :: (HDistProd f p f', Value :<<: f) => p -> Int -> HTerm f' Int
+> iConstP p x = HTerm (hinjectP p $ hinj $ Const x)
+>
+> iPairP :: (HDistProd f p f', Value :<<: f) => p -> HTerm f' a -> HTerm f' b -> HTerm f' (a,b)
+> iPairP p x y = HTerm (hinjectP p $ hinj $ Pair x y)
+>
+> iFstP :: (HDistProd f p f', Op :<<: f) => p -> HTerm f' (a,b) -> HTerm f' a
+> iFstP p x = HTerm (hinjectP p $ hinj $ Fst x)
+>
+> iSndP :: (HDistProd f p f', Op :<<: f) => p -> HTerm f' (a,b) -> HTerm f' b
+> iSndP p x = HTerm (hinjectP p $ hinj $ 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 :: HTerm 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Algebra.hs
@@ -0,0 +1,475 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators, ScopedTypeVariables, 
+  FlexibleContexts #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Algebra
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@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.
+-- All definitions are generalised versions of those in "Data.Comp.Algebra".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Algebra (
+      -- * Algebras & Catamorphisms
+      HAlg,
+      hfree,
+      hcata,
+      hcata',
+      appHCxt,
+      
+      -- * Monadic Algebras & Catamorphisms
+      HAlgM,
+--      halgM,
+      hfreeM,
+      hcataM,
+      hcataM',
+      liftMHAlg,
+
+      -- * Term Homomorphisms
+      HCxtFun,
+      HSigFun,
+      HTermHom,
+      appHTermHom,
+      compHTermHom,
+      appHSigFun,
+      compHSigFun,
+      htermHom,
+      compHAlg,
+--      compHCoalg,
+--      compHCVCoalg,
+
+      -- * Monadic Term Homomorphisms
+      HCxtFunM,
+      HSigFunM,
+      HTermHomM,
+--      HSigFunM',
+--      HTermHomM',
+      hsigFunM,
+--      htermHom',
+      appHTermHomM,
+      htermHomM,
+--      htermHomM',
+      appHSigFunM,
+--      appHSigFunM',
+      compHTermHomM,
+      compHSigFunM,
+      compHAlgM,
+      compHAlgM',
+
+      -- * Coalgebras & Anamorphisms
+      HCoalg,
+      hana,
+--      hana',
+      HCoalgM,
+      hanaM,
+
+      -- * R-Algebras & Paramorphisms
+      HRAlg,
+      hpara,
+      HRAlgM,
+      hparaM,
+
+      -- * R-Coalgebras & Apomorphisms
+      HRCoalg,
+      hapo,
+      HRCoalgM,
+      hapoM,
+
+      -- * CV-Algebras & Histomorphisms
+      -- $l1
+--      HCVAlg,
+--      hhisto,
+--      HCVAlgM,
+--      hhistoM,
+
+      -- * CV-Coalgebras & Futumorphisms
+      HCVCoalg,
+      hfutu,
+--      HCVCoalg',
+--      hfutu',
+      HCVCoalgM,
+      hfutuM,
+
+      -- * Exponential Functors
+      appHTermHomE,
+      hcataE,
+--      hanaE,
+      appHCxtE
+    ) where
+
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Traversable
+import Data.Comp.Multi.ExpFunctor
+import Data.Comp.Ops
+
+import Control.Monad
+
+
+type HAlg f e = f e :-> e
+
+hfree :: forall f h a b . (HFunctor f) =>
+              HAlg f b -> (a :-> b) -> HCxt h f a :-> b
+hfree f g = run
+    where run :: HCxt h f a :-> b
+          run (HHole v) = g v
+          run (HTerm c) = f $ hfmap run c
+
+
+hcata :: forall f a. (HFunctor f) => HAlg f a -> HTerm f :-> a
+hcata f = run 
+    where run :: HTerm f :-> a
+          run (HTerm t) = f (hfmap run t)
+
+hcata' :: (HFunctor f) => HAlg f e -> HCxt h f e :-> e
+hcata' alg = hfree alg id
+
+-- | This function applies a whole context into another context.
+
+appHCxt :: (HFunctor f) => HContext f (HCxt h f a) :-> HCxt h f a
+appHCxt = hcata' HTerm
+
+-- | This function lifts a many-sorted algebra to a monadic domain.
+liftMHAlg :: forall m f. (Monad m, HTraversable f) =>
+            HAlg f I -> HAlg f m
+liftMHAlg alg =  turn . liftM alg . hmapM run
+    where run :: m i -> m (I i)
+          run m = do x <- m
+                     return $ I x
+          turn x = do I y <- x
+                      return y
+
+type HAlgM m f e = NatM m (f e) e
+
+hfreeM :: forall f m h a b. (HTraversable f, Monad m) =>
+               HAlgM m f b -> NatM m a b -> NatM m (HCxt h f a)  b
+hfreeM algm var = run
+    where run :: NatM m (HCxt h f a) b
+          run (HHole x) = var x
+          run (HTerm x) = hmapM run x >>= algm
+
+-- | This is a monadic version of 'hcata'.
+
+hcataM :: forall f m a. (HTraversable f, Monad m) =>
+         HAlgM m f a -> NatM m (HTerm f) a
+-- hcataM alg h (HTerm t) = alg =<< hmapM (hcataM alg h) t
+hcataM alg = run
+    where run :: NatM m (HTerm f) a
+          run (HTerm x) = alg =<< hmapM run x
+
+
+hcataM' :: forall m h a f. (Monad m, HTraversable f) => HAlgM m f a -> NatM m (HCxt h f a) a
+-- hcataM' alg = hfreeM alg return
+hcataM' f = run
+    where run :: NatM m (HCxt h f a) a
+          run (HHole x) = return x
+          run (HTerm x) = hmapM run x >>= f
+
+-- | This type represents context function.
+
+type HCxtFun f g = forall a h. HCxt h f a :-> HCxt h g a
+
+-- | This type represents uniform signature function specification.
+
+type HSigFun f g = forall a. f a :-> g a
+
+
+-- | This type represents a term algebra.
+
+type HTermHom f g = HSigFun f (HContext g)
+
+-- | This function applies the given term homomorphism to a
+-- term/context.
+
+appHTermHom :: (HFunctor f, HFunctor g) => HTermHom f g -> HCxtFun f g
+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type
+-- (Functor f, Functor g) => (f (HCxt h g b) -> HContext g (HCxt h g b)) -> HCxt h f b -> HCxt h g b
+-- would achieve the same. The given type is chosen for clarity.
+appHTermHom _ (HHole b) = HHole b
+appHTermHom f (HTerm t) = appHCxt . f . hfmap (appHTermHom f) $ t
+
+-- | This function composes two term algebras.
+
+compHTermHom :: (HFunctor g, HFunctor h) => HTermHom g h -> HTermHom f g -> HTermHom f h
+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type
+-- (Functor f, Functor g) => (f (HCxt h g b) -> HContext g (HCxt h g b))
+-- -> (a -> HCxt h f b) -> a -> HCxt h g b
+-- would achieve the same. The given type is chosen for clarity.
+compHTermHom f g = appHTermHom f . g
+
+-- | This function composes a term algebra with an algebra.
+
+compHAlg :: (HFunctor g) => HAlg g a -> HTermHom f g -> HAlg f a
+compHAlg alg talg = hcata' alg . talg
+
+-- | This function applies a signature function to the given context.
+
+appHSigFun :: (HFunctor f, HFunctor g) => HSigFun f g -> HCxtFun f g
+appHSigFun f = appHTermHom $ htermHom f
+
+
+-- | This function composes two signature functions.
+
+compHSigFun :: HSigFun g h -> HSigFun f g -> HSigFun f h
+compHSigFun f g = f . g
+
+
+
+
+-- | Lifts the given signature function to the canonical term homomorphism.
+htermHom :: (HFunctor g) => HSigFun f g -> HTermHom f g
+htermHom f = simpHCxt . f
+
+-- | This type represents monadic context function.
+
+type HCxtFunM m f g = forall a h. NatM m (HCxt h f a) (HCxt h g a)
+
+-- | This type represents monadic signature functions.
+
+type HSigFunM m f g = forall a. NatM m (f a) (g a)
+
+
+-- | This type represents monadic term algebras.
+
+type HTermHomM m f g = HSigFunM m f (HContext 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.
+
+hsigFunM :: (Monad m) => HSigFun f g -> HSigFunM m f g
+hsigFunM f = return . f
+
+-- | This function lifts the give monadic signature function to a
+-- monadic term algebra.
+
+htermHom' :: (HFunctor f, HFunctor g, Monad m) =>
+            HSigFunM m f g -> HTermHomM m f g
+htermHom' f = liftM  (HTerm . hfmap HHole) . f
+
+-- | This function lifts the given signature function to a monadic
+-- term algebra.
+
+htermHomM :: (HFunctor g, Monad m) => HSigFun f g -> HTermHomM m f g
+htermHomM f = hsigFunM $ htermHom f
+
+-- | This function applies the given monadic term homomorphism to the
+-- given term/context.
+
+appHTermHomM :: forall f g m . (HTraversable f, HFunctor g, Monad m)
+         => HTermHomM m f g -> HCxtFunM m f g
+appHTermHomM f = run
+    where run :: NatM m (HCxt h f a) (HCxt h g a)
+          run (HHole b) = return $ HHole b
+          run (HTerm t) = liftM appHCxt . (>>= f) . hmapM run $ t
+
+-- | This function applies the given monadic signature function to the
+-- given context.
+
+appHSigFunM :: (HTraversable f, HFunctor g, Monad m) =>
+                HSigFunM m f g -> HCxtFunM m f g
+appHSigFunM f = appHTermHomM $ htermHom' f
+
+-- | This function composes two monadic term algebras.
+
+compHTermHomM :: (HTraversable g, HFunctor h, Monad m)
+             => HTermHomM m g h -> HTermHomM m f g -> HTermHomM m f h
+compHTermHomM f g a = g a >>= appHTermHomM f
+
+{-| This function composes a monadic term algebra with a monadic algebra -}
+
+compHAlgM :: (HTraversable g, Monad m) => HAlgM m g a -> HTermHomM m f g -> HAlgM m f a
+compHAlgM alg talg c = hcataM' alg =<< talg c
+
+-- | This function composes a monadic term algebra with a monadic
+-- algebra.
+
+compHAlgM' :: (HTraversable g, Monad m) => HAlgM m g a -> HTermHom f g -> HAlgM m f a
+compHAlgM' alg talg = hcataM' alg . talg
+
+
+{-| This function composes two monadic signature functions.  -}
+
+compHSigFunM :: (Monad m) => HSigFunM m g h -> HSigFunM m f g -> HSigFunM m f h
+compHSigFunM f g a = g a >>= f
+
+
+----------------
+-- Coalgebras --
+----------------
+
+type HCoalg f a = a :-> f a
+
+{-| This function unfolds the given value to a term using the given
+unravelling function. This is the unique homomorphism @a -> HTerm f@
+from the given coalgebra of type @a -> f a@ to the final coalgebra
+@HTerm f@. -}
+
+hana :: forall f a. HFunctor f => HCoalg f a -> a :-> HTerm f
+hana f = run
+    where run :: a :-> HTerm f
+          run t = HTerm $ hfmap run (f t)
+
+type HCoalgM m f a = NatM m a (f a)
+
+-- | This function unfolds the given value to a term using the given
+-- monadic unravelling function. This is the unique homomorphism @a ->
+-- HTerm f@ from the given coalgebra of type @a -> f a@ to the final
+-- coalgebra @HTerm f@.
+
+hanaM :: forall a m f. (HTraversable f, Monad m)
+          => HCoalgM m f a -> NatM m a (HTerm f)
+hanaM f = run 
+    where run :: NatM m a (HTerm f)
+          run t = liftM HTerm $ f t >>= hmapM run
+
+--------------------------------
+-- R-Algebras & Paramorphisms --
+--------------------------------
+
+-- | This type represents r-algebras over functor @f@ and with domain
+-- @a@.
+
+type HRAlg f a = f (HTerm f :*: a) :-> a
+
+-- | This function constructs a paramorphism from the given r-algebra
+hpara :: forall f a. (HFunctor f) => HRAlg f a -> HTerm f :-> a
+hpara f = fsnd . hcata run
+    where run :: HAlg f  (HTerm f :*: a)
+          run t = HTerm (hfmap ffst t) :*: f t
+
+-- | This type represents monadic r-algebras over monad @m@ and
+-- functor @f@ and with domain @a@.
+type HRAlgM m f a = NatM m (f (HTerm f :*: a)) a
+
+-- | This function constructs a monadic paramorphism from the given
+-- monadic r-algebra
+hparaM :: forall f m a. (HTraversable f, Monad m) => 
+         HRAlgM m f a -> NatM m(HTerm f)  a
+hparaM f = liftM fsnd . hcataM run
+    where run :: HAlgM m f (HTerm f :*: a)
+          run t = do
+            a <- f t
+            return (HTerm (hfmap ffst t) :*: a)
+
+--------------------------------
+-- R-Coalgebras & Apomorphisms --
+--------------------------------
+
+-- | This type represents r-coalgebras over functor @f@ and with
+-- domain @a@.
+type HRCoalg f a = a :-> f (HTerm f :+: a)
+
+-- | This function constructs an apomorphism from the given
+-- r-coalgebra.
+hapo :: forall f a . (HFunctor f) => HRCoalg f a -> a :-> HTerm f
+hapo f = run 
+    where run :: a :-> HTerm f
+          run = HTerm . hfmap run' . f
+          run' :: HTerm f :+: a :-> HTerm f
+          run' (Inl t) = t
+          run' (Inr a) = run a
+
+-- | This type represents monadic r-coalgebras over monad @m@ and
+-- functor @f@ with domain @a@.
+
+type HRCoalgM m f a = NatM m a (f (HTerm f :+: a))
+
+-- | This function constructs a monadic apomorphism from the given
+-- monadic r-coalgebra.
+hapoM :: forall f m a . (HTraversable f, Monad m) =>
+        HRCoalgM m f a -> NatM m a (HTerm f)
+hapoM f = run 
+    where run :: NatM m a (HTerm f)
+          run a = do
+            t <- f a
+            t' <- hmapM run' t
+            return $ HTerm t'
+          run' :: NatM m (HTerm f :+: a)  (HTerm 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 --
+-----------------------------------
+
+
+-- | This type represents cv-coalgebras over functor @f@ and with domain
+-- @a@.
+
+type HCVCoalg f a = a :-> f (HContext f a)
+
+
+-- | This function constructs the unique futumorphism from the given
+-- cv-coalgebra to the term algebra.
+
+hfutu :: forall f a . HFunctor f => HCVCoalg f a -> a :-> HTerm f
+hfutu coa = hana run . HHole
+    where run :: HCoalg f (HContext f a)
+          run (HHole a) = coa a
+          run (HTerm v) = v
+
+
+-- | This type represents monadic cv-coalgebras over monad @m@ and
+-- functor @f@, and with domain @a@.
+
+type HCVCoalgM m f a = NatM m a (f (HContext f a))
+
+-- | This function constructs the unique monadic futumorphism from the
+-- given monadic cv-coalgebra to the term algebra.
+hfutuM :: forall f a m . (HTraversable f, Monad m) =>
+         HCVCoalgM m f a -> NatM m a (HTerm f)
+hfutuM coa = hanaM run . HHole
+    where run :: HCoalgM m f (HContext f a)
+          run (HHole a) = coa a
+          run (HTerm v) = return v
+
+
+--------------------------
+-- Exponential Functors --
+--------------------------
+
+{-| Catamorphism for higher-order exponential functors. -}
+hcataE :: forall f a . HExpFunctor f => HAlg f a -> HTerm f :-> a
+hcataE f = cataFS . toHCxt
+    where cataFS :: HExpFunctor f => HContext f a :-> a
+          cataFS (HHole x) = x
+          cataFS (HTerm t) = f (hxmap cataFS HHole t)
+
+
+{-{-| Anamorphism for higher-order exponential functors. -}
+hanaE :: forall a f . HExpFunctor f => HCoalg f a -> a :-> HTerm (f :&: a)
+hanaE f = run
+    where run :: a :-> HTerm (f :&: a)
+          run t = HTerm $ hxmap run (snd . hprojectP . unHTerm) (f t) :&: t-}
+
+-- | Variant of 'appHCxt' for contexts over 'HExpFunctor' signatures.
+appHCxtE :: (HExpFunctor f) => HContext f (HCxt h f a) :-> HCxt h f a
+appHCxtE (HHole x) = x
+appHCxtE (HTerm t)  = HTerm (hxmap appHCxtE HHole t)
+
+-- | Variant of 'appHTermHom' for term homomorphisms from and to
+-- 'HExpFunctor' signatures.
+appHTermHomE :: forall f g . (HExpFunctor f, HExpFunctor g) => HTermHom f g
+             -> HTerm f :-> HTerm g
+appHTermHomE f = cataFS . toHCxt
+    where cataFS :: HContext f (HTerm g) :-> HTerm g
+          cataFS (HHole x) = x
+          cataFS (HTerm t) = appHCxtE (f (hxmap cataFS HHole t))
diff --git a/src/Data/Comp/Multi/Equality.hs b/src/Data/Comp/Multi/Equality.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Equality.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE TypeOperators, GADTs, FlexibleInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Equality
+-- Copyright   :  (c) Patrick Bahr, 2011
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines equality for (higher-order) signatures, which lifts to
+-- equality for (higher-order) terms and contexts. All definitions are
+-- generalised versions of those in "Data.Comp.Equality".
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Multi.Equality
+    (
+     HEqF(..),
+     KEq(..),
+     heqMod
+    ) where
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Sum
+import Data.Comp.Derive
+
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+
+{-|
+  'EqF' is propagated through sums.
+-}
+
+instance (HEqF f, HEqF g) => HEqF (f :++: g) where
+    heqF (HInl x) (HInl y) = heqF x y
+    heqF (HInr x) (HInr y) = heqF x y
+    heqF _ _ = False
+
+{-|
+  From an 'EqF' functor an 'Eq' instance of the corresponding
+  term type can be derived.
+-}
+instance (HEqF f) => HEqF (HCxt h f) where
+
+    heqF (HTerm e1) (HTerm e2) = e1 `heqF` e2
+    heqF (HHole h1) (HHole h2) = h1 `keq` h2
+    heqF _ _ = False
+
+instance (HEqF f, KEq a)  => KEq (HCxt h f a) where
+    keq = heqF
+
+instance KEq HNothing where
+    keq _ = undefined
+
+
+{-| This function implements equality of values of type @f a@ modulo
+the equality of @a@ itself. If two functorial values are equal in this
+sense, 'eqMod' returns a 'Just' value containing a list of pairs
+consisting of corresponding components of the two functorial
+values. -}
+
+heqMod :: (HEqF f, HFunctor f, HFoldable f) => f a i -> f b i -> Maybe [(A a, A b)]
+heqMod s t
+    | unit s `heqF` unit' t = Just args
+    | otherwise = Nothing
+    where unit = hfmap (const $ K ())
+          unit' = hfmap (const $ K ())
+          args = htoList s `zip` htoList t
diff --git a/src/Data/Comp/Multi/ExpFunctor.hs b/src/Data/Comp/Multi/ExpFunctor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/ExpFunctor.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TypeOperators, RankNTypes #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.ExpFunctor
+-- Copyright   :  (c) 2011 Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines higher-order exponential functors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.ExpFunctor
+    (
+      HExpFunctor(..)
+    ) where
+
+import Data.Comp.Multi.Functor
+
+{-| Higher-order exponential functors are higher-order functors that may be both covariant (as ordinary higher-order functors) and contravariant. -}
+class HExpFunctor f where
+    hxmap :: (a :-> b) -> (b :-> a) -> f a :-> f b
diff --git a/src/Data/Comp/Multi/Foldable.hs b/src/Data/Comp/Multi/Foldable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Foldable.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Foldable
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines higher-order foldable functors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Foldable
+    (
+     HFoldable (..),
+     kfoldr,
+     kfoldl,
+     htoList
+     ) where
+
+import Data.Monoid
+import Data.Maybe
+import Data.Comp.Multi.Functor
+
+-- | Higher-order functors that can be folded.
+--
+-- Minimal complete definition: 'hfoldMap' or 'hfoldr'.
+class HFunctor h => HFoldable h where
+    hfold :: Monoid m => h (K m) :=> m
+    hfold = hfoldMap unK
+
+    hfoldMap :: Monoid m => (a :=> m) -> h a :=> m
+    hfoldMap f = hfoldr (mappend . f) mempty
+
+    hfoldr :: (a :=> b -> b) -> b -> h a :=> b
+    hfoldr f z t = appEndo (hfoldMap (Endo . f) t) z
+
+    hfoldl :: (b -> a :=> b) -> b -> h a :=> b
+    hfoldl f z t = appEndo (getDual (hfoldMap (Dual . Endo . flip f) t)) z
+
+
+    hfoldr1 :: forall a. (a -> a -> a) -> h (K a) :=> a
+    hfoldr1 f xs = fromMaybe (error "hfoldr1: empty structure")
+                   (hfoldr mf Nothing xs)
+          where mf :: K a :=> Maybe a -> Maybe a
+                mf (K x) Nothing = Just x
+                mf (K x) (Just y) = Just (f x y)
+
+    hfoldl1 :: forall a . (a -> a -> a) -> h (K a) :=> a
+    hfoldl1 f xs = fromMaybe (error "hfoldl1: empty structure")
+                   (hfoldl mf Nothing xs)
+          where mf :: Maybe a -> K a :=> Maybe a
+                mf Nothing (K y) = Just y
+                mf (Just x) (K y) = Just (f x y)
+
+htoList :: (HFoldable f) => f a :=> [A a]
+htoList = hfoldr (\ n l ->  A n : l) []
+    
+kfoldr :: (HFoldable f) => (a -> b -> b) -> b -> f (K a) :=> b
+kfoldr f = hfoldr (\ (K x) y -> f x y)
+
+
+kfoldl :: (HFoldable f) => (b -> a -> b) -> b -> f (K a) :=> b
+kfoldl f = hfoldl (\ x (K y) -> f x y)
diff --git a/src/Data/Comp/Multi/Functor.hs b/src/Data/Comp/Multi/Functor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Functor.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Functor
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines higher-order functors (Johann, Ghani, POPL
+-- '08), i.e. endofunctors on the category of endofunctors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Functor
+    (
+     HFunctor (..),
+     (:->),
+     (:=>),
+     NatM,
+     I (..),
+     K (..),
+     A (..),
+     (:.:)(..)
+     ) where
+
+-- | The identity Functor.
+data I a = I {unI :: a}
+
+-- | The parametrised constant functor.
+data K a b = K {unK :: a}
+
+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 ->
+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 co-cones from @f@ to @a@. @f :=> a@ is
+-- isomorphic to f :-> K a
+type f :=> a = forall i . f i -> a
+
+
+type NatM m f g = forall i. f i -> m (g i)
+
+-- | This class represents higher-order functors (Johann, Ghani, POPL
+-- '08) which are endofunctors on the category of endofunctors.
+class HFunctor h where
+    -- A higher-order functor @f@ maps every functor @g@ to a
+    -- functor @f g@.
+    --
+    -- @ffmap :: (Functor g) => (a -> b) -> f g a -> f g b@
+    -- 
+    -- We omit this, as it does not work for GADTs (see Johand and
+    -- Ghani 2008).
+
+    -- | A higher-order functor @f@ also maps a natural transformation
+    -- @g :-> h@ to a natural transformation @f g :-> f h@
+    hfmap :: (f :-> g) -> h f :-> h g
+
+infixl 5 :.:
+
+-- | This data type denotes the composition of two functor families.
+data (f :.: g) e t = Comp f (g e) t
diff --git a/src/Data/Comp/Multi/Ops.hs b/src/Data/Comp/Multi/Ops.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Ops.hs
@@ -0,0 +1,164 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,
+             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
+             ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, KindSignatures #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Ops
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides operators on higher-order functors. All definitions are
+-- generalised versions of those in "Data.Comp.Ops".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Ops where
+
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+import Data.Comp.Multi.Traversable
+import Data.Comp.Multi.ExpFunctor
+import Data.Comp.Ops
+import Control.Monad
+import Control.Applicative
+
+
+infixr 5 :++:
+
+
+-- |Data type defining coproducts.
+data (f :++: g) (h :: * -> *) e = HInl (f h e)
+                    | HInr (g h e)
+
+instance (HFunctor f, HFunctor g) => HFunctor (f :++: g) where
+    hfmap f (HInl v) = HInl $ hfmap f v
+    hfmap f (HInr v) = HInr $ hfmap f v
+
+instance (HFoldable f, HFoldable g) => HFoldable (f :++: g) where
+    hfold (HInl e) = hfold e
+    hfold (HInr e) = hfold e
+    hfoldMap f (HInl e) = hfoldMap f e
+    hfoldMap f (HInr e) = hfoldMap f e
+    hfoldr f b (HInl e) = hfoldr f b e
+    hfoldr f b (HInr e) = hfoldr f b e
+    hfoldl f b (HInl e) = hfoldl f b e
+    hfoldl f b (HInr e) = hfoldl f b e
+
+    hfoldr1 f (HInl e) = hfoldr1 f e
+    hfoldr1 f (HInr e) = hfoldr1 f e
+    hfoldl1 f (HInl e) = hfoldl1 f e
+    hfoldl1 f (HInr e) = hfoldl1 f e
+
+instance (HTraversable f, HTraversable g) => HTraversable (f :++: g) where
+    htraverse f (HInl e) = HInl <$> htraverse f e
+    htraverse f (HInr e) = HInr <$> htraverse f e
+    hmapM f (HInl e) = HInl `liftM` hmapM f e
+    hmapM f (HInr e) = HInr `liftM` hmapM f e
+
+instance (HExpFunctor f, HExpFunctor g) => HExpFunctor (f :++: g) where
+    hxmap f g (HInl v) = HInl $ hxmap f g v
+    hxmap f g (HInr v) = HInr $ hxmap f g v
+
+-- |The subsumption relation.
+class (sub :: (* -> *) -> * -> *) :<<: sup where
+    hinj :: sub a :-> sup a
+    hproj :: NatM Maybe (sup a) (sub a)
+
+instance (:<<:) f f where
+    hinj = id
+    hproj = Just
+
+instance (:<<:) f (f :++: g) where
+    hinj = HInl
+    hproj (HInl x) = Just x
+    hproj (HInr _) = Nothing
+
+instance (f :<<: g) => (:<<:) f (h :++: g) where
+    hinj = HInr . hinj
+    hproj (HInr x) = hproj x
+    hproj (HInl _) = Nothing
+
+-- Products
+
+infixr 8 :**:
+
+data (f :**: g) a = f a :**: g a
+
+
+hfst :: (f :**: g) a -> f a
+hfst (x :**: _) = x
+
+hsnd :: (f :**: g) a -> g a
+hsnd (_ :**: x) = x
+
+-- Constant Products
+
+infixr 7 :&&:
+
+-- | This data type adds a constant product to a
+-- signature. Alternatively, this could have also been defined as
+-- 
+-- @data (f :&&: a) (g ::  * -> *) e = f g e :&&: a e@
+-- 
+-- This is too general, however, for example for 'productHTermHom'.
+
+data (f :&&: a) (g ::  * -> *) e = f g e :&&: a
+
+
+instance (HFunctor f) => HFunctor (f :&&: a) where
+    hfmap f (v :&&: c) = hfmap f v :&&: c
+
+instance (HFoldable f) => HFoldable (f :&&: a) where
+    hfold (v :&&: _) = hfold v
+    hfoldMap f (v :&&: _) = hfoldMap f v
+    hfoldr f e (v :&&: _) = hfoldr f e v
+    hfoldl f e (v :&&: _) = hfoldl f e v
+    hfoldr1 f (v :&&: _) = hfoldr1 f v
+    hfoldl1 f (v :&&: _) = hfoldl1 f v
+
+
+instance (HTraversable f) => HTraversable (f :&&: a) where
+    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
+-- signatures.
+
+class HDistProd (s :: (* -> *) -> * -> *) p s' | s' -> s, s' -> p where
+        
+    -- | This function injects a product a value over a signature.
+    hinjectP :: p -> s a :-> s' a
+    hprojectP :: s' a :-> (s a :&: p)
+
+
+class HRemoveP (s :: (* -> *) -> * -> *) s' | s -> s'  where
+    hremoveP :: s a :-> s' a
+
+
+instance (HRemoveP s s') => HRemoveP (f :&&: p :++: s) (f :++: s') where
+    hremoveP (HInl (v :&&: _)) = HInl v
+    hremoveP (HInr v) = HInr $ hremoveP v
+
+
+instance HRemoveP (f :&&: p) f where
+    hremoveP (v :&&: _) = v
+
+
+instance HDistProd f p (f :&&: p) where
+
+    hinjectP p v = v :&&: p
+
+    hprojectP (v :&&: p) = v :&: p
+
+
+instance (HDistProd s p s') => HDistProd (f :++: s) p ((f :&&: p) :++: s') where
+    hinjectP p (HInl v) = HInl (v :&&: p)
+    hinjectP p (HInr v) = HInr $ hinjectP p v
+
+    hprojectP (HInl (v :&&: p)) = (HInl v :&: p)
+    hprojectP (HInr v) = let (v' :&: p) = hprojectP v
+                        in  (HInr v' :&: p)
diff --git a/src/Data/Comp/Multi/Product.hs b/src/Data/Comp/Multi/Product.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Product.hs
@@ -0,0 +1,87 @@
+{-# 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
+    ( (:&&:) (..),
+      HDistProd (..),
+      HRemoveP (..),
+      liftP,
+      constP,
+      liftP',
+      stripP,
+      productHTermHom,
+      hproject'
+    )where
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Ops
+import Data.Comp.Ops
+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 :: (HRemoveP s s') => (s' a :-> t) -> s a :-> t
+liftP f v = f (hremoveP v)
+
+
+-- | This function annotates each sub term of the given term with the
+-- given value (of type a).
+
+constP :: (HDistProd f p g, HFunctor f, HFunctor g) 
+       => p -> HCxt h f a :-> HCxt h g a
+constP c = appHSigFun (hinjectP 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' :: (HDistProd s' p s, HFunctor s, HFunctor s')
+       => (s' a :-> HCxt h s' a) -> s a :-> HCxt h s a
+liftP' f v = let (v' :&: p) = hprojectP v
+             in constP p (f v')
+    
+{-| This function strips the products from a term over a
+functor whith products. -}
+
+stripP :: (HFunctor f, HRemoveP g f, HFunctor g)
+       => HCxt h g a :-> HCxt h f a
+stripP = appHSigFun hremoveP
+
+
+productHTermHom :: (HDistProd f p f', HDistProd g p g', HFunctor g, HFunctor g') 
+               => HTermHom f g -> HTermHom f' g'
+productHTermHom alg f' = constP p (alg f)
+    where (f :&: p) = hprojectP f'
+
+
+
+
+
+-- | This function is similar to 'hproject' but applies to signatures
+-- with a product which is then ignored.
+
+-- hproject' :: (HRemoveP s s',s :<<: f) =>
+--      NatM Maybe (HCxt h f a) (s' (HCxt h f a))
+hproject' v = liftM hremoveP $ hproject v
diff --git a/src/Data/Comp/Multi/Show.hs b/src/Data/Comp/Multi/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Show.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeOperators, GADTs, FlexibleContexts,
+  ScopedTypeVariables, UndecidableInstances, FlexibleInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Show
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines showing of (higher-order) signatures, which lifts to
+-- showing of (higher-order) terms and contexts. All definitions are
+-- generalised versions of those in "Data.Comp.Show".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Show
+    ( HShowF(..)
+    ) where
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Product
+import Data.Comp.Multi.Algebra
+import Data.Comp.Multi.Functor
+import Data.Comp.Derive
+
+instance KShow HNothing where
+    kshow _ = undefined
+instance KShow (K String) where
+    kshow = id
+
+instance (HShowF f, HFunctor f) => HShowF (HCxt h f) where
+    hshowF (HHole s) = s
+    hshowF (HTerm t) = hshowF $ hfmap hshowF t
+
+instance (HShowF f, HFunctor f, KShow a) => KShow (HCxt h f a) where
+    kshow = hfree hshowF kshow
+
+instance (KShow f) => Show (f i) where
+    show = unK . kshow
+
+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 (HInl f) = hshowF f
+    hshowF (HInr g) = hshowF g
diff --git a/src/Data/Comp/Multi/Sum.hs b/src/Data/Comp/Multi/Sum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Sum.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, IncoherentInstances,
+  RankNTypes #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Sum
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines sums on signatures. All definitions are
+-- generalised versions of those in "Data.Comp.Sum".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Sum
+    (
+     (:<<:)(..),
+     (:++:)(..),
+
+     -- * Projections for Signatures and Terms
+     hproj2,
+     hproj3,
+     hproject,
+     hproject2,
+     hproject3,
+     deepHProject,
+     deepHProject2,
+     deepHProject3,
+--     deepHProject',
+--     deepHProject2',
+--     deepHProject3',
+
+     -- * Injections for Signatures and Terms
+     hinj2,
+     hinj3,
+     hinject,
+     hinject2,
+     hinject3,
+     deepHInject,
+     deepHInject2,
+     deepHInject3,
+     deepHInjectE,
+     deepHInjectE2,
+     deepHInjectE3,
+
+     -- * Injections and Projections for Constants
+     hinjectHConst,
+     hinjectHConst2,
+     hinjectHConst3,
+     hprojectHConst,
+     hinjectHCxt,
+     liftHCxt,
+     substHHoles,
+--     substHHoles'
+    ) where
+
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Traversable
+import Data.Comp.Multi.ExpFunctor
+import Data.Comp.Multi.Ops
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Algebra
+import Control.Monad (liftM)
+
+{-| A variant of 'hproj' for binary sum signatures.  -}
+hproj2 :: forall f g1 g2 a i. (g1 :<<: f, g2 :<<: f) =>
+          f a i -> Maybe (((g1 :++: g2) a) i)
+hproj2 x = case hproj x of
+             Just (y :: g1 a i) -> Just $ hinj y
+             _ -> liftM hinj (hproj x :: Maybe (g2 a i))
+
+{-| A variant of 'hproj' for ternary sum signatures.  -}
+hproj3 :: forall f g1 g2 g3 a i. (g1 :<<: f, g2 :<<: f, g3 :<<: f) =>
+          f a i -> Maybe (((g1 :++: g2 :++: g3) a) i)
+hproj3 x = case hproj x of
+             Just (y :: g1 a i) -> Just $ hinj y
+             _ -> case hproj x of
+                    Just (y :: g2 a i) -> Just $ hinj y
+                    _ -> liftM hinj (hproj x :: Maybe (g3 a i))
+
+-- |Project the outermost layer of a term to a sub signature.
+hproject :: (g :<<: f) => NatM Maybe (HCxt h f a)  (g (HCxt h f a))
+hproject (HHole _) = Nothing
+hproject (HTerm t) = hproj t
+
+-- |Project the outermost layer of a term to a binary sub signature.
+hproject2 :: (g1 :<<: f, g2 :<<: f) =>
+             NatM Maybe (HCxt h f a) ((g1 :++: g2) (HCxt h f a))
+hproject2 (HHole _) = Nothing
+hproject2 (HTerm t) = hproj2 t
+
+-- |Project the outermost layer of a term to a ternary sub signature.
+hproject3 :: (g1 :<<: f, g2 :<<: f, g3 :<<: f) =>
+             NatM Maybe (HCxt h f a) ((g1 :++: g2 :++: g3) (HCxt h f a))
+hproject3 (HHole _) = Nothing
+hproject3 (HTerm t) = hproj3 t
+
+-- |Project a term to a term over a sub signature.
+deepHProject :: (HTraversable f, HFunctor g, g :<<: f)
+             => NatM Maybe (HCxt h f a) (HCxt h g a)
+deepHProject = appHSigFunM hproj
+
+-- |Project a term to a term over a binary sub signature.
+deepHProject2 :: (HTraversable f, HFunctor g1, HFunctor g2,
+                  g1 :<<: f, g2 :<<: f)
+              => NatM Maybe (HCxt h f a) (HCxt h (g1 :++: g2) a)
+deepHProject2 = appHSigFunM hproj2
+
+-- |Project a term to a term over a ternary sub signature.
+deepHProject3 :: (HTraversable f, HFunctor g1, HFunctor g2, HFunctor g3,
+                  g1 :<<: f, g2 :<<: f, g3 :<<: f)
+              => NatM Maybe (HCxt h f a) (HCxt h (g1 :++: g2 :++: g3) a)
+deepHProject3 = appHSigFunM hproj3
+
+{-| A variant of 'hinj' for binary sum signatures.  -}
+hinj2 :: (f1 :<<: g, f2 :<<: g) => (f1 :++: f2) a :-> g a
+hinj2 (HInl x) = hinj x
+hinj2 (HInr y) = hinj y
+
+{-| A variant of 'hinj' for ternary sum signatures.  -}
+hinj3 :: (f1 :<<: g, f2 :<<: g, f3 :<<: g) => (f1 :++: f2 :++: f3) a :-> g a
+hinj3 (HInl x) = hinj x
+hinj3 (HInr y) = hinj2 y
+
+-- |Inject a term where the outermost layer is a sub signature.
+hinject :: (g :<<: f) => g (HCxt h f a) :-> HCxt h f a
+hinject = HTerm . hinj
+
+-- |Inject a term where the outermost layer is a binary sub signature.
+hinject2 :: (f1 :<<: g, f2 :<<: g) => (f1 :++: f2) (HCxt h g a) :-> HCxt h g a
+hinject2 = HTerm . hinj2
+
+-- |Inject a term where the outermost layer is a ternary sub signature.
+hinject3 :: (f1 :<<: g, f2 :<<: g, f3 :<<: g)
+         => (f1 :++: f2 :++: f3) (HCxt h g a) :-> HCxt h g a
+hinject3 = HTerm . hinj3
+
+-- |Inject a term over a sub signature to a term over larger signature.
+deepHInject :: (HFunctor g, HFunctor f, g :<<: f) => HCxt h g a :-> HCxt h f a
+deepHInject = appHSigFun hinj
+
+-- |Inject a term over a binary sub signature to a term over larger signature.
+deepHInject2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<<: g, f2 :<<: g)
+             => HCxt h (f1 :++: f2) a :-> HCxt h g a
+deepHInject2 = appHSigFun hinj2
+
+-- |Inject a term over a ternary sub signature to a term over larger signature.
+deepHInject3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,
+                 f1 :<<: g, f2 :<<: g, f3 :<<: g)
+             => HCxt h (f1 :++: f2 :++: f3) a :-> HCxt h g a
+deepHInject3 = appHSigFun hinj3
+
+{-| A variant of 'deepHInject' for exponential signatures. -}
+deepHInjectE :: (HExpFunctor g, g :<<: f) => HTerm g :-> HTerm f
+deepHInjectE = hcataE hinject
+
+{-| A variant of 'deepHInject2' for exponential signatures. -}
+deepHInjectE2 :: (HExpFunctor g1, HExpFunctor g2, g1 :<<: f, g2 :<<: f) =>
+                 HTerm (g1 :++: g2) :-> HTerm f
+deepHInjectE2 = hcataE hinject2
+
+{-| A variant of 'deepHInject3' for exponential signatures. -}
+deepHInjectE3 :: (HExpFunctor g1, HExpFunctor g2, HExpFunctor g3,
+                  g1 :<<: f, g2 :<<: f, g3 :<<: f) =>
+                 HTerm (g1 :++: g2 :++: g3) :-> HTerm f
+deepHInjectE3 = hcataE hinject3
+
+-- | This function injects a whole context into another context.
+hinjectHCxt :: (HFunctor g, g :<<: f) => HCxt h' g (HCxt h f a) :-> HCxt h f a
+hinjectHCxt = hcata' hinject
+
+-- | This function lifts the given functor to a context.
+liftHCxt :: (HFunctor f, g :<<: f) => g a :-> HContext f a
+liftHCxt g = simpHCxt $ hinj g
+
+-- | This function applies the given context with hole type @a@ to a
+-- family @f@ of contexts (possibly terms) indexed by @a@. That is,
+-- each hole @h@ is replaced by the context @f h@.
+
+substHHoles :: (HFunctor f, HFunctor g, f :<<: g)
+           => (v :-> HCxt h g a) -> HCxt h' f v :-> HCxt h g a
+substHHoles f c = hinjectHCxt $ hfmap f c
+
+hinjectHConst :: (HFunctor g, g :<<: f) => HConst g :-> HCxt h f a
+hinjectHConst = hinject . hfmap (const undefined)
+
+hinjectHConst2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<<: g, f2 :<<: g)
+               => HConst (f1 :++: f2) :-> HCxt h g a
+hinjectHConst2 = hinject2 . hfmap (const undefined)
+
+hinjectHConst3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,
+                   f1 :<<: g, f2 :<<: g, f3 :<<: g)
+               => HConst (f1 :++: f2 :++: f3) :-> HCxt h g a
+hinjectHConst3 = hinject3 . hfmap (const undefined)
+
+hprojectHConst :: (HFunctor g, g :<<: f) => NatM Maybe (HCxt h f a) (HConst g)
+hprojectHConst = fmap (hfmap (const (K ()))) . hproject
diff --git a/src/Data/Comp/Multi/Term.hs b/src/Data/Comp/Multi/Term.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Term.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes,
+  TypeOperators, ScopedTypeVariables, IncoherentInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Term
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the central notion of mutual recursive (or, higher-order)
+-- /terms/ and its generalisation to (higher-order) contexts. All definitions
+-- are generalised versions of those in "Data.Comp.Term".
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Term 
+    (HCxt (..),
+     HHole,
+     HNoHole,
+     HContext,
+     HNothing,
+     HTerm,
+     HConst,
+     constHTerm,
+     unHTerm,
+     toHCxt,
+     simpHCxt
+     ) where
+
+import Data.Comp.Multi.Functor
+import Unsafe.Coerce
+
+type HConst (f :: (* -> *) -> * -> *) = f (K ())
+
+-- | 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 functor f.
+
+constHTerm :: (HFunctor f) => HConst f :-> HTerm f
+constHTerm = HTerm . hfmap (const undefined)
+
+-- | This data type represents contexts over a signature. Contexts are
+-- terms containing zero or more holes. The first type parameter is
+-- supposed to be one of the phantom types 'HHole' and 'HNoHole'. The
+-- second parameter is the signature of the context. The third
+-- parameter is the type family of the holes. The last parameter is
+-- the index/label.
+
+data HCxt h f a i where
+    HTerm ::  f (HCxt h f a) i -> HCxt h f a i
+    HHole :: a i -> HCxt HHole f a i
+
+-- | Phantom type that signals that a 'HCxt' might contain holes.
+data HHole
+-- | Phantom type that signals that a 'HCxt' does not contain holes.
+data HNoHole
+
+-- | A context might contain holes.
+type HContext = HCxt HHole
+
+{-| Phantom type family used to define 'HTerm'.  -}
+data HNothing :: * -> *
+
+instance Show (HNothing i) where
+instance Eq (HNothing i) where
+instance Ord (HNothing i) where
+
+-- | A (higher-order) term is a context with no holes.
+type HTerm f = HCxt HNoHole f HNothing
+
+-- | This function unravels the given term at the topmost layer.
+unHTerm :: HTerm f t -> f (HTerm f) t
+unHTerm (HTerm t) = t
+
+instance (HFunctor f) => HFunctor (HCxt h f) where
+    hfmap f (HHole x) = HHole (f x)
+    hfmap f (HTerm t) = HTerm (hfmap (hfmap f) t)
+
+
+simpHCxt :: (HFunctor f) => f a i -> HContext f a i
+simpHCxt = HTerm . hfmap HHole
+
+toHCxt :: HTerm f i -> HContext f a i
+toHCxt = unsafeCoerce
+--toHCxt :: (HFunctor f) => HTerm f i -> HContext f a i
+--toHCxt (HTerm t) = HTerm $ hfmap toHCxt t
diff --git a/src/Data/Comp/Multi/Traversable.hs b/src/Data/Comp/Multi/Traversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Traversable.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Traversable
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines higher-order traversable functors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Multi.Traversable
+    (
+     HTraversable (..)
+    ) where
+
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+import Control.Applicative
+
+class HFoldable t => HTraversable t where
+
+    -- | Map each element of a structure to a monadic action, evaluate
+    -- these actions from left to right, and collect the results.
+    --
+    -- Alternative type in terms of natural transformations using
+    -- functor composition @:.:@:
+    --
+    -- @hmapM :: Monad m => (a :-> m :.: b) -> t a :-> m :.: (t b)@
+    hmapM :: (Monad m) => NatM m a b -> NatM m (t a) (t b)
+
+    htraverse :: (Applicative f) => NatM f a b -> NatM f (t a) (t b)
diff --git a/src/Data/Comp/Multi/Variables.hs b/src/Data/Comp/Multi/Variables.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Multi/Variables.hs
@@ -0,0 +1,151 @@
+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,
+  OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Multi.Variables
+-- Copyright   :  (c) 2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines an abstraction notion of a variable in a term. All
+-- definitions are generalised versions of those in "Data.Comp.Variables".
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Multi.Variables  where
+
+import Data.Comp.Multi.Term
+import Data.Comp.Multi.Sum
+import Data.Comp.Multi.Algebra
+import Data.Comp.Multi.Functor
+import Data.Comp.Multi.Foldable
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.Maybe
+
+
+-- type HCxtSubst h a f v =  [A (v :*: (HCxt h f a))]
+
+-- type Subst f v = HCxtSubst HNoHole HNothing f v
+
+type GSubst v a = NatM Maybe (K v) a
+
+type HCxtSubst h a f v =  GSubst v (HCxt h f a)
+
+type Subst f v = HCxtSubst HNoHole HNothing f v
+
+{-| This multiparameter class defines functors with variables. An
+instance @HasVar f v@ denotes that values over @f@ might contain
+variables of type @v@. -}
+
+class HasVars (f  :: (* -> *) -> * -> *) v where
+    isVar :: f a :=> Maybe v
+    isVar _ = Nothing
+
+instance (HasVars f v, HasVars g v) => HasVars (f :++: g) v where
+    isVar (HInl v) = isVar v
+    isVar (HInr v) = isVar v
+
+instance HasVars f v => HasVars (HCxt h f) v where
+    isVar (HTerm t) = isVar t
+    isVar _ = Nothing
+
+varsToHHoles :: forall f v. (HFunctor f, HasVars f v) => HTerm f :-> HContext f (K v)
+varsToHHoles = hcata alg
+    where alg :: HAlg f (HContext f (K v))
+          alg t = case isVar t of 
+                    Just v -> HHole $ K v
+                    Nothing -> HTerm t
+
+containsVarAlg :: (Eq v, HasVars f v, HFoldable f) => v -> HAlg f (K Bool)
+containsVarAlg v t = K $ local || kfoldl (||) False t 
+    where local = case isVar t of
+                    Just v' -> v == v'
+                    Nothing -> False
+
+{-| This function checks whether a variable is contained in a
+context. -}
+
+containsVar :: (Eq v, HasVars f v, HFoldable f, HFunctor f)
+            => v -> HCxt h f a :=> Bool
+containsVar v = unK . hfree (containsVarAlg v) (const $ K False)
+
+
+variableListAlg :: (HasVars f v, HFoldable f)
+            => HAlg f (K [v])
+variableListAlg t = K $ kfoldl (++) local t
+    where local = case isVar t of
+                    Just v -> [v]
+                    Nothing -> [] 
+
+{-| This function computes the list of variables occurring in a
+context. -}
+
+variableList :: (HasVars f v, HFoldable f, HFunctor f)
+            => HCxt h f a :=> [v]
+variableList = unK . hfree variableListAlg (const $ K [])
+
+
+
+variablesAlg :: (Ord v, HasVars f v, HFoldable f)
+            => HAlg f (K (Set v))
+variablesAlg t = K $ kfoldl Set.union local t
+    where local = case isVar t of
+                    Just v -> Set.singleton v
+                    Nothing -> Set.empty
+
+{-| This function computes the set of variables occurring in a
+context. -}
+
+variables :: (Ord v, HasVars f v, HFoldable f, HFunctor f)
+            => HCxt h f a :=> Set v
+variables = unK . hfree variablesAlg (const $ K Set.empty)
+
+{-| This function computes the set of variables occurring in a
+context. -}
+
+variables' :: (Ord v, HasVars f v, HFoldable f, HFunctor f)
+            => HConst f :=> Set v
+variables' c =  case isVar c of
+                  Nothing -> Set.empty
+                  Just v -> Set.singleton v
+
+
+
+substAlg :: (HasVars f v) => HCxtSubst h a f v -> HAlg f (HCxt h f a)
+substAlg f t = fromMaybe (HTerm t) (isVar t >>= f . K)
+
+{-| This function substitutes variables in a context according to a
+partial mapping from variables to contexts.-}
+
+class SubstVars v t a where
+    substVars :: GSubst v t -> a :-> a
+
+
+appSubst :: SubstVars v t a => GSubst v t -> a :-> a
+appSubst = substVars
+
+instance (Ord v, HasVars f v, HFunctor f) => SubstVars v (HCxt h f a) (HCxt h f a) where
+    substVars f (HTerm v) = substAlg f $ hfmap (substVars f) v
+    substVars _ (HHole a) = HHole a
+-- have to use explicit GADT pattern matching!!
+-- subst f = hfree (substAlg f) HHole
+
+instance (SubstVars v t a, HFunctor f) => SubstVars v t (f a) where
+    substVars f = hfmap (substVars f) 
+
+
+
+{-| This function composes two substitutions @s1@ and @s2@. That is,
+applying the resulting substitution is equivalent to first applying
+@s2@ and then @s1@. -}
+
+compSubst :: (Ord v, HasVars f v, HFunctor f)
+          => HCxtSubst h a f v -> HCxtSubst h a f v -> HCxtSubst h a f v
+compSubst s1 s2 v = case s2 v of
+                      Nothing -> s1 v
+                      Just t -> Just $ appSubst s1 t
diff --git a/src/Data/Comp/Ops.hs b/src/Data/Comp/Ops.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Ops.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,
+             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
+             ScopedTypeVariables, FunctionalDependencies, UndecidableInstances #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Ops
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides operators on functors.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Ops where
+
+import Data.Foldable
+import Data.Traversable
+
+import Control.Applicative
+import Control.Monad hiding (sequence, mapM)
+
+import Data.Comp.ExpFunctor
+
+import Prelude hiding (foldl, mapM, sequence, foldl1, foldr1, foldr)
+
+
+-- Sums
+
+infixr 6 :+:
+
+
+-- |Formal sum of signatures (functors).
+data (f :+: g) e = Inl (f e)
+                 | Inr (g e)
+
+instance (Functor f, Functor g) => Functor (f :+: g) where
+    fmap f (Inl e) = Inl (fmap f e)
+    fmap f (Inr e) = Inr (fmap f e)
+
+instance (Foldable f, Foldable g) => Foldable (f :+: g) where
+    fold (Inl e) = fold e
+    fold (Inr e) = fold e
+    foldMap f (Inl e) = foldMap f e
+    foldMap f (Inr e) = foldMap f e
+    foldr f b (Inl e) = foldr f b e
+    foldr f b (Inr e) = foldr f b e
+    foldl f b (Inl e) = foldl f b e
+    foldl f b (Inr e) = foldl f b e
+    foldr1 f (Inl e) = foldr1 f e
+    foldr1 f (Inr e) = foldr1 f e
+    foldl1 f (Inl e) = foldl1 f e
+    foldl1 f (Inr e) = foldl1 f e
+
+instance (Traversable f, Traversable g) => Traversable (f :+: g) where
+    traverse f (Inl e) = Inl <$> traverse f e
+    traverse f (Inr e) = Inr <$> traverse f e
+    sequenceA (Inl e) = Inl <$> sequenceA e
+    sequenceA (Inr e) = Inr <$> sequenceA e
+    mapM f (Inl e) = Inl `liftM` mapM f e
+    mapM f (Inr e) = Inr `liftM` mapM f e
+    sequence (Inl e) = Inl `liftM` sequence e
+    sequence (Inr e) = Inr `liftM` sequence e
+
+instance (ExpFunctor f, ExpFunctor g) => ExpFunctor (f :+: g) where
+    xmap f g (Inl e) = Inl (xmap f g e)
+    xmap f g (Inr e) = Inr (xmap f g 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 -> sup a
+  proj :: sup a -> Maybe (sub a)
+
+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 (functors).
+data (f :*: g) a = f a :*: g a
+
+
+ffst :: (f :*: g) a -> f a
+ffst (x :*: _) = x
+
+fsnd :: (f :*: g) a -> g a
+fsnd (_ :*: x) = x
+
+-- Constant Products
+
+infixr 7 :&:
+
+{-| This data type adds a constant product to a signature.  -}
+
+data (f :&: a) e = f e :&: a
+
+
+instance (Functor f) => Functor (f :&: a) where
+    fmap f (v :&: c) = fmap f v :&: c
+
+instance (Foldable f) => Foldable (f :&: a) where
+    fold (v :&: _) = fold v
+    foldMap f (v :&: _) = foldMap f v
+    foldr f e (v :&: _) = foldr f e v
+    foldl f e (v :&: _) = foldl f e v
+    foldr1 f (v :&: _) = foldr1 f v
+    foldl1 f (v :&: _) = foldl1 f v
+
+instance (Traversable f) => Traversable (f :&: a) where
+    traverse f (v :&: c) = liftA (:&: c) (traverse f v)
+    sequenceA (v :&: c) = liftA (:&: c)(sequenceA v)
+    mapM f (v :&: c) = liftM (:&: c) (mapM f v)
+    sequence (v :&: c) = liftM (:&: c) (sequence v)
+
+instance (ExpFunctor f) => ExpFunctor (f :&: a) where
+    xmap f g (v :&: c) = xmap f g v :&: c
+
+{-| This class defines how to distribute a product 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 RemoveP s s' | s -> s'  where
+    {-| Remove products from a signature. -}
+    removeP :: 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 RemoveP (f :&: p) f where
+    removeP (v :&: _) = v
+
+
+instance DistProd f p (f :&: p) where
+
+    injectP c v = v :&: c
+
+    projectP (v :&: p) = (v,p)
+
+
+instance (DistProd s p s') => DistProd (f :+: s) p ((f :&: p) :+: s') where
+
+
+    injectP c (Inl v) = Inl (v :&: c)
+    injectP c (Inr v) = Inr $ injectP c v
+
+    projectP (Inl (v :&: p)) = (Inl v,p)
+    projectP (Inr v) = let (v',p) = projectP v
+                       in  (Inr v',p)
diff --git a/src/Data/Comp/Ordering.hs b/src/Data/Comp/Ordering.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Ordering.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Ordering
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@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.Ordering
+    (
+     OrdF(..)
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Equality ()
+import Data.Comp.Derive
+import Data.Comp.Derive.Utils
+
+
+instance (OrdF f, Ord a) => Ord (Cxt h f a) where
+    compare = compareF
+
+{-|
+  From an 'OrdF' functor an 'Ord' instance of the corresponding
+  term type can be derived.
+-}
+instance (OrdF f) => OrdF (Cxt h f) where
+    compareF (Term e1) (Term e2) = compareF e1 e2
+    compareF (Hole h1) (Hole h2) = compare h1 h2
+    compareF Term{} Hole{} = LT
+    compareF Hole{} Term{} = GT
+
+-- instance (OrdF f, Ord p) => OrdF (f :*: p) where
+--     compareF (v1 :*: p1) (v2 :*: p2) = 
+--         case compareF v1 v2 of
+--           EQ ->  compare p1 p2
+--           res -> res
+
+{-|
+  '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)
diff --git a/src/Data/Comp/Product.hs b/src/Data/Comp/Product.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Product.hs
@@ -0,0 +1,75 @@
+{-# 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
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Show.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell, TypeSynonymInstances #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Show
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines showing of signatures, which lifts to showing of
+-- terms and contexts.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Show
+    ( ShowF(..)
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Product
+import Data.Comp.Algebra
+import Data.Comp.Derive
+
+instance (Functor f, ShowF f) => ShowF (Cxt h f) where
+    showF (Hole s) = s
+    showF (Term t) = showF $ fmap showF t
+
+instance (Functor f, ShowF f, Show a) => Show (Cxt h f a) where
+    show = free showF show
+
+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, ''[], ''(,)])
diff --git a/src/Data/Comp/Sum.hs b/src/Data/Comp/Sum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Sum.hs
@@ -0,0 +1,257 @@
+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,
+             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,
+             ScopedTypeVariables #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Sum
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module provides the infrastructure to extend signatures.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Sum
+    (
+     (:<:)(..),
+     (:+:)(..),
+
+     -- * Projections for Signatures and Terms
+     proj2,
+     proj3,
+     project,
+     project2,
+     project3,
+     deepProject,
+     deepProject2,
+     deepProject3,
+     deepProject',
+     deepProject2',
+     deepProject3',
+
+     -- * Injections for Signatures and Terms
+     inj2,
+     inj3,
+     inject,
+     inject2,
+     inject3,
+     deepInject,
+     deepInject2,
+     deepInject3,
+     deepInjectE,
+     deepInjectE2,
+     deepInjectE3,
+
+     -- * Injections and Projections for Constants
+     injectConst,
+     injectConst2,
+     injectConst3,
+     projectConst,
+     injectCxt,
+     liftCxt,
+     substHoles,
+     substHoles'
+    ) where
+
+import Data.Comp.Term
+import Data.Comp.Algebra
+import Data.Comp.Ops
+import Data.Comp.ExpFunctor
+
+import Control.Monad hiding (sequence)
+import Prelude hiding (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))
+
+-- |Project the outermost layer of a term to a sub signature.
+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'
+
+-- |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'
+
+{-| 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
+
+{-| 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
+
+-- |Inject a term where the outermost layer is a sub signature.
+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
+
+-- |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
+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
+
+{-| A variant of 'deepInject' for exponential signatures. -}
+deepInjectE :: (ExpFunctor g, g :<: f) => Term g -> Term f
+deepInjectE = cataE inject
+
+{-| A variant of 'deepInject2' for exponential signatures. -}
+deepInjectE2 :: (ExpFunctor g1, ExpFunctor g2, g1 :<: f, g2 :<: f) =>
+                Term (g1 :+: g2)
+             -> Term f
+deepInjectE2 = cataE inject2
+
+{-| A variant of 'deepInject3' for exponential signatures. -}
+deepInjectE3 :: (ExpFunctor g1, ExpFunctor g2, ExpFunctor g3,
+                 g1 :<: f, g2 :<: f, g3 :<: f) =>
+                Term (g1 :+: g2 :+: g3)
+             -> Term f
+deepInjectE3 = cataE inject3
+
+injectConst :: (Functor g, g :<: f) => Const g -> Cxt h f a
+injectConst = inject . fmap (const undefined)
+
+injectConst2 :: (Functor f1, Functor f2, Functor g, f1 :<: g, f2 :<: g)
+             => Const (f1 :+: f2) -> Cxt h g a
+injectConst2 = inject2 . fmap (const undefined)
+
+injectConst3 :: (Functor f1, Functor f2, Functor f3, Functor g, f1 :<: g, f2 :<: g, f3 :<: g)
+             => Const (f1 :+: f2 :+: f3) -> Cxt h g a
+injectConst3 = inject3 . fmap (const undefined)
+
+projectConst :: (Functor g, g :<: f) => Cxt h f a -> Maybe (Const g)
+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
+
+{-| This function lifts the given functor to a context. -}
+liftCxt :: (Functor f, g :<: f) => g a -> Context f a
+liftCxt g = simpCxt $ inj g
+
+{-| This function applies the given context with hole type @a@ to a
+family @f@ of contexts (possibly terms) indexed by @a@. That is, each
+hole @h@ is replaced by the context @f h@. -}
+
+substHoles :: (Functor f, Functor g, f :<: g) => Cxt h' f v -> (v -> Cxt h g a) -> Cxt h g a
+substHoles c f = injectCxt $ fmap f c
+
+substHoles' :: (Functor f, Functor g, f :<: g, Ord v) => Cxt h' f v -> Map v (Cxt h g a) -> Cxt h g a
+substHoles' c m = substHoles c (fromJust . (`Map.lookup`  m))
+
+instance (Functor f) => Monad (Context f) where
+    return = Hole
+    (>>=) = substHoles
+
+
+instance (Show (f a), Show (g a)) => Show ((f :+: g) a) where
+    show (Inl v) = show v
+    show (Inr v) = show v
+
+
+instance (Ord (f a), Ord (g a)) => Ord ((f :+: g) a) 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), Eq (g a)) => Eq ((f :+: g) a) where
+    (Inl x) == (Inl y) = x == y
+    (Inr x) == (Inr y) = x == y                   
+    _ == _ = False
diff --git a/src/Data/Comp/Term.hs b/src/Data/Comp/Term.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Term.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Term
+-- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines the central notion of /terms/ and its
+-- generalisation to contexts.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.Term
+    (Cxt (..),
+     Hole,
+     NoHole,
+     Context,
+     Nothing,
+     Term,
+     PTerm,
+     Const,
+     unTerm,
+     simpCxt,
+     toCxt,
+     constTerm
+     ) where
+
+import Control.Applicative hiding (Const)
+import Control.Monad hiding (mapM, sequence)
+
+import Data.Traversable
+import Data.Foldable
+
+import Unsafe.Coerce
+
+import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)
+
+
+{-|  -}
+type Const f = f ()
+
+{-| 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 functor @f@. -}
+
+constTerm :: (Functor f) => Const f -> Term f
+constTerm = Term . fmap (const undefined)
+
+{-| This data type represents contexts over a signature. Contexts are
+terms containing zero or more holes. The first type parameter is
+supposed to be one of the phantom types 'Hole' and 'NoHole'. The
+second parameter is the signature of the context. The third parameter
+is the type of the holes. -}
+
+data Cxt :: * -> (* -> *) -> * -> * where
+            Term :: f (Cxt h f a) -> Cxt h f a
+            Hole :: a -> Cxt Hole f a
+
+
+{-| Phantom type that signals that a 'Cxt' might contain holes.  -}
+
+data Hole
+
+{-| Phantom type that signals that a 'Cxt' does not contain holes.
+-}
+
+data NoHole
+
+type Context = Cxt Hole
+
+{-| Convert a functorial value into a context.  -}
+simpCxt :: (Functor f) => f a -> Context f a
+{-# INLINE simpCxt #-}
+simpCxt = Term . fmap Hole
+
+
+{-| Cast a term over a signature to a context over the same signature. -}
+toCxt :: Term f -> Cxt h f a
+{-# INLINE toCxt #-}
+toCxt = unsafeCoerce
+
+{-| Phantom type used to define 'Term'.  -}
+
+data Nothing
+
+instance Eq Nothing where
+instance Ord Nothing where
+instance Show Nothing where
+
+
+
+{-| A term is a context with no holes.  -}
+
+type Term f = Cxt NoHole f Nothing
+
+-- | Polymorphic definition of a term. This formulation is more
+-- natural than 'Term', it leads to impredicative types in some cases,
+-- though.
+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)
+
+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
+
+    foldl op e (Hole a) = e `op` a
+    foldl op e (Term t) = foldl op' e t
+        where op' = foldl op
+
+    fold (Hole a) = a
+    fold (Term t) = foldMap fold t
+
+    foldMap f (Hole a) = f a
+    foldMap f (Term t) = foldMap (foldMap f) 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
+                          
+    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
+
+    sequence (Hole a) = liftM Hole a
+    sequence (Term t) = liftM Term $ mapM sequence t
+
+
+
+{-| This function unravels the given term at the topmost layer.  -}
+
+unTerm :: Cxt NoHole f a -> f (Cxt NoHole f a)
+{-# INLINE unTerm #-}
+unTerm (Term t) = t
diff --git a/src/Data/Comp/TermRewriting.hs b/src/Data/Comp/TermRewriting.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/TermRewriting.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE RankNTypes, GADTs #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.TermRewriting
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines term rewriting systems (TRSs) using compositional data
+-- types.
+--
+--------------------------------------------------------------------------------
+
+module Data.Comp.TermRewriting where
+
+import Prelude hiding (any)
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Algebra
+import Data.Comp.Equality
+import Data.Comp.Matching
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe
+import Data.Foldable
+
+import Control.Monad
+
+
+{-| This type represents /recursive program schemes/.  -}
+
+type RPS f g  = TermHom f g
+
+type Var = Int
+
+{-| This type represents term rewrite rules from signature @f@ to
+signature @g@ over variables of type @v@ -}
+
+type Rule f g v = (Context f v, Context g v)
+
+
+{-| This type represents term rewriting systems (TRSs) from signature
+@f@ to signature @g@ over variables of type @v@. -}
+
+type TRS f g v = [Rule f g v]
+
+type Step t = t -> Maybe t
+type BStep t = t -> (t,Bool)
+
+{-| This function tries to match the given rule against the given term
+(resp. context in general) at the root. If successful, the function
+returns the right hand side of the rule and the matching
+substitution. -}
+
+matchRule ::  (Ord v, EqF f, Eq a, Functor f, Foldable f)
+          => Rule f g v -> Cxt h f a -> Maybe (Context g v, Map v (Cxt h f a))
+matchRule (lhs,rhs) t = do
+  subst <- matchCxt lhs t
+  return (rhs,subst)
+
+matchRules :: (Ord v, EqF f, Eq a, Functor f, Foldable f)
+           => TRS f g v -> Cxt h f a -> Maybe (Context g v, Map v (Cxt h f a))
+matchRules trs t = listToMaybe $ mapMaybe (`matchRule` t) trs
+
+{-| This function tries to apply the given rule at the root of the
+given term (resp. context in general). If successful, the function
+returns the result term of the rewrite step; otherwise @Nothing@. -}
+
+appRule :: (Ord v, EqF f, Eq a, Functor f, Foldable f)
+          => Rule f f v -> Step (Cxt h f a)
+appRule rule t = do 
+  (res, subst) <- matchRule rule t
+  return $ substHoles' res subst
+
+{-| This function tries to apply one of the rules in the given TRS at
+the root of the given term (resp. context in general) by trying each
+rule one by one using 'appRule' until one rule is applicable. If no
+rule is applicable @Nothing@ is returned. -}
+
+appTRS :: (Ord v, EqF f, Eq a, Functor f, Foldable f)
+         => TRS f f v -> Step (Cxt h f a)
+appTRS trs t = listToMaybe $ mapMaybe (`appRule` t) trs
+
+
+{-| This is an auxiliary function that turns function @f@ of type
+  @(t -> Maybe t)@ into functions @f'@ of type @t -> (t,Bool)@. @f' x@
+  evaluates to @(y,True)@ if @f x@ evaluates to @Just y@, and to
+  @(x,False)@ if @f x@ evaluates to @Nothing@. This function is useful
+  to change the output of functions that apply rules such as 'appTRS'. -}
+
+bStep :: Step t -> BStep t
+bStep f t = case f t of
+                Nothing -> (t, False)
+                Just t' -> (t',True)
+
+{-| This function performs a parallel reduction step by trying to
+apply rules of the given system to all outermost redexes. If the given
+term contains no redexes, @Nothing@ is returned. -}
+
+parTopStep :: (Ord v, EqF f, Eq a, Foldable f, Functor f)
+           => TRS f f v -> Step (Cxt h f a)
+parTopStep _ Hole{} = Nothing
+parTopStep trs c@(Term t) = tTop `mplus` tBelow'
+    where tTop = appTRS trs c
+          tBelow = fmap (bStep $ parTopStep trs) t
+          tAny = any snd tBelow
+          tBelow'
+              | tAny = Just $ Term $ fmap fst tBelow
+              | otherwise = Nothing
+
+{-| This function performs a parallel reduction step by trying to
+apply rules of the given system to all outermost redexes and then
+recursively in the variable positions of the redexes. If the given
+term does not contain any redexes, @Nothing@ is returned. -}
+
+parallelStep :: (Ord v, EqF f, Eq a,Foldable f, Functor  f)
+             => TRS f f v -> Step (Cxt h f a)
+parallelStep _ Hole{} = Nothing
+parallelStep trs c@(Term t) =
+    case matchRules trs c of
+      Nothing 
+          | anyBelow -> Just $ Term $ fmap fst below
+          | otherwise -> Nothing
+        where below = fmap (bStep $ parallelStep trs) t 
+              anyBelow = any snd below
+      Just (rhs,subst) -> Just $ substHoles' rhs substBelow
+          where rhsVars = Set.fromList $ toList rhs
+                substBelow = Map.mapMaybeWithKey apply subst
+                apply v t
+                    | Set.member v rhsVars = Just $ fst $ bStep (parallelStep trs) t
+                    | otherwise = Nothing
+                
+
+{-| This function applies the given reduction step repeatedly until a
+normal form is reached. -}
+
+reduce :: Step t -> t -> t
+reduce s t = case s t of
+               Nothing -> t
+               Just t' -> reduce s t'
diff --git a/src/Data/Comp/Unification.hs b/src/Data/Comp/Unification.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Unification.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE FlexibleContexts #-}
+-------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Unification
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module implements a simple unification algorithm using compositional
+-- data types.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Unification where
+
+import Data.Comp.Term
+import Data.Comp.Variables
+import Data.Comp.Decompose
+
+import Control.Monad.Error
+import Control.Monad.State
+
+import qualified Data.Map as Map
+
+{-| This type represents equations between terms over a specific
+signature. -}
+
+type Equation f = (Term f,Term f)
+
+{-| This type represents list of equations. -}
+
+type Equations f = [Equation f]
+
+{-| This type represents errors that might occur during the
+unification.  -}
+
+data UnifError f v = FailedOccursCheck v (Term f)
+                   | HeadSymbolMismatch (Term f) (Term f)
+                   | UnifError String
+
+instance Error (UnifError f v) where
+    strMsg = UnifError
+
+
+failedOccursCheck :: (MonadError (UnifError f v) m) => v -> Term f -> m a
+failedOccursCheck v t = throwError $ FailedOccursCheck v t
+
+headSymbolMismatch :: (MonadError (UnifError f v) m) => Term f -> Term f -> m a
+headSymbolMismatch f g = throwError $ HeadSymbolMismatch f g
+
+appSubstEq :: (Ord v,  HasVars f v, Functor f) =>
+     Subst f v -> Equation f -> Equation f
+appSubstEq s (t1,t2) = (appSubst s t1,appSubst s t2)
+
+
+{-| This function returns the most general unifier of the given
+equations using the algorithm of Martelli and Montanari. -}
+
+unify :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f))
+      => Equations f -> m (Subst f v)
+unify = runUnifyM runUnify
+
+data UnifyState f v = UnifyState {usEqs ::Equations f, usSubst :: Subst f v}
+type UnifyM f v m a = StateT (UnifyState f v) m a
+
+runUnifyM :: MonadError (UnifError f v) m
+          => UnifyM f v m a -> Equations f -> m (Subst f v)
+runUnifyM m eqs = liftM (usSubst . snd) $
+                           runStateT m UnifyState { usEqs = eqs, usSubst = Map.empty}
+
+withNextEq :: Monad m
+           => (Equation f -> UnifyM f v m ()) -> UnifyM f v m ()
+withNextEq m = do eqs <- gets usEqs
+                  case eqs of 
+                    [] -> return ()
+                    x : xs -> modify (\s -> s {usEqs = xs})
+                           >> m x
+
+putEqs :: Monad m 
+       => Equations f -> UnifyM f v m ()
+putEqs eqs = modify addEqs
+    where addEqs s = s {usEqs = eqs ++ usEqs s}
+
+putBinding :: (Monad m, Ord v, HasVars f v, Functor f) => (v, Term f) -> UnifyM f v m ()
+putBinding bind = modify appSubst
+    where binds = Map.fromList [bind]
+          appSubst s = s { usEqs = map (appSubstEq binds) (usEqs s),
+                             usSubst = compSubst binds (usSubst s)}
+
+
+runUnify :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f))
+         => UnifyM f v m ()
+runUnify = withNextEq (\ e -> unifyStep e >> runUnify)
+
+unifyStep :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f)) 
+          => Equation f -> UnifyM f v m ()
+unifyStep (s,t) = case decompose s of
+                    Var v1 -> case decompose t of
+                                 Var v2 -> unless (v1 == v2) $
+                                             putBinding (v1, t)
+                                 _ -> if containsVar v1 t
+                                      then failedOccursCheck v1 t
+                                      else putBinding (v1,t)
+                    Fun s1 args1 -> case decompose t of
+                                       Var v -> if containsVar v s
+                                                 then failedOccursCheck v s
+                                                 else putBinding (v,s)
+                                       Fun s2 args2 -> if s1 == s2
+                                                        then putEqs $ zip args1 args2
+                                                        else headSymbolMismatch s t
diff --git a/src/Data/Comp/Variables.hs b/src/Data/Comp/Variables.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Comp/Variables.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,
+  OverlappingInstances, TypeOperators #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Comp.Variables
+-- Copyright   :  (c) 2010-2011 Patrick Bahr
+-- License     :  BSD3
+-- Maintainer  :  Patrick Bahr <paba@diku.dk>
+-- Stability   :  experimental
+-- Portability :  non-portable (GHC Extensions)
+--
+-- This module defines an abstraction notion of a variable in compositional
+-- data type.
+--
+--------------------------------------------------------------------------------
+module Data.Comp.Variables (
+  HasVars(..),
+  Subst,
+  CxtSubst,
+  varsToHoles,
+  containsVar,
+  variables,
+  variableList,
+  variables',
+  substVars,
+  appSubst,
+  compSubst) where
+
+import Data.Comp.Term
+import Data.Comp.Sum
+import Data.Comp.Algebra
+import Data.Foldable
+
+import Data.Maybe
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Prelude hiding (or, foldl)
+
+type CxtSubst h a f v = Map v (Cxt h f a)
+
+type Subst f v = CxtSubst NoHole Nothing f v
+
+{-| This multiparameter class defines functors with variables. An
+instance @HasVar f v@ denotes that values over @f@ might contain
+variables of type @v@. -}
+
+class HasVars f v where
+    isVar :: f a -> Maybe v
+    isVar _ = Nothing
+
+instance (HasVars f v, HasVars g v) => HasVars (f :+: g) v where
+    isVar (Inl v) = isVar v
+    isVar (Inr v) = isVar v
+
+instance HasVars f v => HasVars (Cxt h f) v where
+    isVar (Term t) = isVar t
+    isVar _ = Nothing
+
+varsToHoles :: (Functor f, HasVars f v) => Term f -> Context f v
+varsToHoles = cata alg
+    where alg t = case isVar t of 
+                    Just v -> Hole v
+                    Nothing -> Term t
+
+containsVarAlg :: (Eq v, HasVars f v, Foldable f) => v -> Alg f Bool
+containsVarAlg v t = local || or t 
+    where local = case isVar t of
+                    Just v' -> v == v'
+                    Nothing -> False
+
+{-| This function checks whether a variable is contained in a
+context. -}
+
+containsVar :: (Eq v, HasVars f v, Foldable f, Functor f)
+            => v -> Cxt h f a -> Bool
+containsVar v = free (containsVarAlg v) (const False)
+
+variablesAlg :: (Ord v, HasVars f v, Foldable f)
+            => Alg f (Set v)
+variablesAlg t = foldl Set.union local t
+    where local = case isVar t of
+                    Just v -> Set.singleton v
+                    Nothing -> Set.empty
+
+variableListAlg :: (Ord v, HasVars f v, Foldable f)
+            => Alg f [v]
+variableListAlg t = foldl (++) local t
+    where local = case isVar t of
+                    Just v -> [v]
+                    Nothing -> [] 
+
+{-| This function computes the list of variables occurring in a
+context. -}
+
+variableList :: (Ord v, HasVars f v, Foldable f, Functor f)
+            => Cxt h f a -> [v]
+variableList = free variableListAlg (const [])
+
+{-| This function computes the set of variables occurring in a
+context. -}
+
+variables :: (Ord v, HasVars f v, Foldable f, Functor f)
+            => Cxt h f a -> Set v
+variables = free variablesAlg (const Set.empty)
+
+{-| This function computes the set of variables occurring in a
+context. -}
+
+variables' :: (Ord v, HasVars f v, Foldable f, Functor f)
+            => Const f -> Set v
+variables' c =  case isVar c of
+                  Nothing -> Set.empty
+                  Just v -> Set.singleton v
+
+
+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)
+
+{-| This function substitutes variables in a context according to a
+partial mapping from variables to contexts.-}
+
+
+
+class SubstVars v t a where
+    substVars :: (v -> Maybe t) -> a -> a
+
+
+appSubst :: (Ord v, SubstVars v t a) => Map v t -> a -> a
+appSubst subst = substVars f
+    where f v = Map.lookup v subst
+
+instance (Ord v, HasVars f v, Functor f) => SubstVars v (Cxt h f a) (Cxt h f a) where
+    substVars f (Term v) = substAlg f $ fmap (substVars f) v
+    substVars _ (Hole a) = Hole a
+-- have to use explicit GADT pattern matching!!
+-- subst f = free (substAlg f) Hole
+
+instance (SubstVars v t a, Functor f) => SubstVars v t (f a) where
+    substVars f = fmap (substVars f) 
+
+
+
+{-| This function composes two substitutions @s1@ and @s2@. That is,
+applying the resulting substitution is equivalent to first applying
+@s2@ and then @s1@. -}
+
+compSubst :: (Ord v, HasVars f v, Functor f)
+          => CxtSubst h a f v -> CxtSubst h a f v -> CxtSubst h a f v
+compSubst s1 s2 = fmap (appSubst s1) s2 `Map.union` s1
diff --git a/testsuite/tests/Data/Comp/Equality_Test.hs b/testsuite/tests/Data/Comp/Equality_Test.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp/Equality_Test.hs
@@ -0,0 +1,37 @@
+module Data.Comp.Equality_Test where
+
+
+import Data.Comp
+import Data.Comp.Equality
+import Data.Comp.Arbitrary
+import Data.Comp.Show
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+
+
+
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+main = defaultMain [tests]
+
+tests = testGroup "Equality" [
+         testProperty "prop_eqMod_fmap" prop_eqMod_fmap
+        ]
+
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
+prop_eqMod_fmap cxt f = case eqMod cxt cxt' of
+                   Nothing -> False
+                   Just list -> all (uncurry (==)) $ map (\(x,y)->(f x,y)) list
+    where cxt' = fmap f cxt 
+          with = (cxt :: Context SigP Int, f :: Int -> Int)
diff --git a/testsuite/tests/Data/Comp_Test.hs b/testsuite/tests/Data/Comp_Test.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data/Comp_Test.hs
@@ -0,0 +1,30 @@
+module Data.Comp_Test where
+
+
+import Data.Comp
+import Data.Comp.Equality
+import Data.Comp.Arbitrary ()
+import Data.Comp.Show ()
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.Utils
+
+import qualified Data.Comp.Equality_Test
+
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+main = defaultMain [tests]
+
+tests = testGroup "Comp" [
+         Data.Comp.Equality_Test.tests
+        ]
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
+
diff --git a/testsuite/tests/Data_Test.hs b/testsuite/tests/Data_Test.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Data_Test.hs
@@ -0,0 +1,18 @@
+module Main where
+
+import Test.Framework
+import qualified Data.Comp_Test
+
+--------------------------------------------------------------------------------
+-- Test Suits
+--------------------------------------------------------------------------------
+
+main = defaultMain [tests]
+
+tests = testGroup "Data" [
+         Data.Comp_Test.tests
+       ]
+
+--------------------------------------------------------------------------------
+-- Properties
+--------------------------------------------------------------------------------
diff --git a/testsuite/tests/Test/Utils.hs b/testsuite/tests/Test/Utils.hs
new file mode 100644
--- /dev/null
+++ b/testsuite/tests/Test/Utils.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleContexts, FlexibleInstances #-}
+
+module Test.Utils where
+
+import Data.Comp
+import Data.Comp.Derive
+
+import Data.Foldable
+
+
+data Tree l e = Leaf l
+              | UnNode l e
+              | BinNode e l e
+              | TerNode l e e e
+
+data Pair a e = Pair a e
+
+$(derive
+  [instanceFunctor, instanceFoldable, instanceShowF, instanceEqF, instanceArbitraryF]
+  [''Tree, ''Pair])
+
+$(derive
+  [smartConstructors]
+  [''Tree, ''Pair, ''Maybe])
+
+
+type Sig1 = Maybe :+: Tree Int
+type Sig2 = [] :+: Pair Int
+type Sig = Maybe :+: Tree Int :+: [] :+: Pair Int
+
+
+type SigP = Maybe :&: Int :+: Tree Int :&: Int :+: [] :&: Int :+: Pair Int :&: Int
+
+instance EqF f => EqF (f :&: Int) where
+    eqF (x :&: i) (y :&: j) = x `eqF` y && i == j
+
+instance Show (a -> b) where
+    show _ = "<function>"