diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,28 @@
+Copyright (c) 2009 Universiteit Utrecht
+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 Universiteit Utrecht nor the names of its contributors
+   may be used to endorse or promote products derived from this software without
+   specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER 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,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/examples/Test.hs b/examples/Test.hs
new file mode 100644
--- /dev/null
+++ b/examples/Test.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE TypeFamilies       #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE EmptyDataDecls     #-}
+
+module Test where
+
+import Generics.Regular
+
+-- * Datatype representing logical expressions
+data Logic = Var String
+           | Logic :->:  Logic  -- implication
+           | Logic :<->: Logic  -- equivalence
+           | Logic :&&:  Logic  -- and (conjunction)
+           | Logic :||:  Logic  -- or (disjunction)
+           | Not Logic          -- not
+           | T                  -- true
+           | F                  -- false
+           deriving Show
+
+-- * Instantiating Regular for Logic using TH
+-- ** Constructors
+$(deriveConstructors ''Logic)
+
+-- ** Functor encoding and 'Regular' instance
+$(deriveRegular ''Logic "PFLogic")
+type instance PF Logic = PFLogic
+
+-- * Example logical expressions
+l1, l2, l3 :: Logic
+l1 = Var "p"
+l2 = Not l1
+l3 = l1 :->: l2
+
+-- * Testing flattening
+ex0 :: [Logic]
+ex0 = flatten (from l3)
+
+-- * Testing generic equality
+ex1, ex2 :: Bool
+ex1 = geq l3 l3
+ex2 = geq l3 l2
+
+-- * Testing generic show
+ex3 :: String
+ex3 = gshow l3 ""
+
+-- * Testing value generation
+ex4, ex5 :: Logic
+ex4 = left
+ex5 = right
+
+-- * Testing folding
+ex6 :: (String -> Bool) -> Logic -> Bool
+ex6 env = fold (env & impl & (==) & (&&) & (||) & not & True & False)
+  where impl p q = not p || q
+
+ex7 :: Bool
+ex7 = ex6 (\_ -> False) l3
diff --git a/regular.cabal b/regular.cabal
new file mode 100644
--- /dev/null
+++ b/regular.cabal
@@ -0,0 +1,48 @@
+name:                   regular
+version:                0.1
+synopsis:               Generic programming library for regular datatypes.
+description:
+
+  This package provides generic functionality for regular datatypes.
+  Regular datatypes are recursive datatypes such as lists, binary trees,
+  etc. This library cannot be used with mutually recursive datatypes or
+  with nested datatypes. The multirec library [1] can deal with mutually
+  recursive datatypes.
+  . 
+  This library has been described in the paper:
+  .
+  *  /A Lightweight Approach to Datatype-Generic Rewriting./
+     Thomas van Noort, Alexey Rodriguez, Stefan Holdermans, Johan Jeuring, Bastiaan Heeren.
+     ACM SIGPLAN Workshop on Generic Programming 2008.
+  .
+  More information about this library can be found at
+  <http://www.cs.uu.nl/wiki/GenericProgramming/Regular>.
+  .
+  \[1] <http://hackage.haskell.org/cgi-bin/hackage-scripts/package/multirec>
+
+category:               Generics
+copyright:              (c) 2009 Universiteit Utrecht
+license:                BSD3
+license-file:           LICENSE
+author:                 Thomas van Noort,
+                        Alexey Rodriguez,
+                        Stefan Holdermans,
+                        Johan Jeuring,
+                        Bastiaan Heeren
+maintainer:             generics@haskell.org
+stability:              experimental
+build-type:             Custom
+cabal-version:          >= 1.2.1
+tested-with:            GHC == 6.10.1
+extra-source-files:     examples/Test.hs
+
+
+library
+  hs-source-dirs:       src
+  exposed-modules:      Generics.Regular
+                        Generics.Regular.Base
+                        Generics.Regular.Functions
+                        Generics.Regular.Constructor
+                        Generics.Regular.TH
+  build-depends:        base >= 4.0 && < 5, template-haskell >= 2.2 && < 2.4
+  ghc-options:          -Wall
diff --git a/src/Generics/Regular.hs b/src/Generics/Regular.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular.hs
@@ -0,0 +1,43 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Top-level module for this library.
+-- By importing this module, the user is able to use all the generic
+-- functionality. The user is only required to provide an instance of
+-- @Regular@ for the datatype.
+--
+-- Consider a datatype representing logical expressions:
+--
+-- >  data Logic = Var String
+-- >             | Logic :->:  Logic  -- implication
+-- >             | Logic :<->: Logic  -- equivalence
+-- >             | Logic :&&:  Logic  -- and (conjunction)
+-- >             | Logic :||:  Logic  -- or (disjunction)
+-- >             | Not Logic          -- not
+-- >             | T                  -- true
+-- >             | F                  -- false
+--
+-- An instance of @Regular@ is derived with TH by invoking:
+--
+-- >  $(deriveConstructors ''Logic)
+-- >  $(deriveRegular ''Logic "PFLogic")
+-- >  type instance PF Logic = PFLogic
+-- 
+-----------------------------------------------------------------------------
+
+module Generics.Regular (
+    module Generics.Regular.Base,
+    module Generics.Regular.Functions,
+    module Generics.Regular.TH
+  ) where
+
+import Generics.Regular.Base
+import Generics.Regular.Functions
+import Generics.Regular.TH
diff --git a/src/Generics/Regular/Base.hs b/src/Generics/Regular/Base.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Base.hs
@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE TypeOperators      #-}
+{-# LANGUAGE TypeFamilies       #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Base
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Types for structural representation.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Base (
+
+    -- * Functorial structural representation types
+    K(..),
+    I(..),
+    U(..),
+    (:+:)(..),
+    (:*:)(..),
+    C(..),
+    Constructor(..), Fixity(..), Associativity(..),
+
+    -- * Fixed-point type
+    Fix (..),
+
+    -- * Type class capturing the structural representation of a type and the corresponding embedding-projection pairs
+    Regular (..), PF
+    
+  ) where
+
+import Generics.Regular.Constructor
+
+
+-----------------------------------------------------------------------------
+-- Functorial structural representation types.
+-----------------------------------------------------------------------------
+
+-- | Structure type for constant values.
+data K a r       = K { unK :: a }
+
+-- | Structure type for recursive values.
+data I r         = I { unI :: r }
+
+-- | Structure type for empty constructors.
+data U r         = U
+
+-- | Structure type for alternatives in a type.
+data (f :+: g) r = L (f r) | R (g r)
+
+-- | Structure type for fields of a constructor.
+data (f :*: g) r = f r :*: g r
+
+-- | Structure type to store the name of a constructor.
+data C c f r =  C { unC :: f r }
+
+infixr 6 :+:
+infixr 7 :*:
+
+-----------------------------------------------------------------------------
+-- Fixed-point type.
+-----------------------------------------------------------------------------
+
+-- | The well-known fixed-point type.
+newtype Fix f = In (f (Fix f))
+
+
+-----------------------------------------------------------------------------
+-- Type class capturing the structural representation of a type and the
+-- corresponding embedding-projection pairs.
+-----------------------------------------------------------------------------
+-- | The type family @PF@ represents the pattern functor of a datatype.
+-- 
+-- To be able to use the generic functions, the user is required to provide
+-- an instance of this type family.
+type family PF a :: * -> *
+
+-- | The type class @Regular@ captures the structural representation of a 
+-- type and the corresponding embedding-projection pairs.
+--
+-- To be able to use the generic functions, the user is required to provide
+-- an instance of this type class.
+class Regular a where
+  from      :: a -> PF a a
+  to        :: PF a a -> a
+
+-----------------------------------------------------------------------------
+-- Functorial map function.
+-----------------------------------------------------------------------------
+
+instance Functor I where
+  fmap f (I r) = I (f r)
+
+instance Functor (K a) where
+  fmap _ (K a) = K a
+
+instance Functor U where
+  fmap _ U = U
+
+instance (Functor f, Functor g) => Functor (f :+: g) where
+  fmap f (L x) = L (fmap f x)
+  fmap f (R y) = R (fmap f y)
+
+instance (Functor f, Functor g) => Functor (f :*: g) where
+  fmap f (x :*: y) = fmap f x :*: fmap f y
+
+instance Functor f => Functor (C c f) where
+  fmap f (C r) = C (fmap f r)
diff --git a/src/Generics/Regular/Constructor.hs b/src/Generics/Regular/Constructor.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Constructor.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE KindSignatures       #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Constructor
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Representation for constructors.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Constructor (
+    Constructor(..), Fixity(..), Associativity(..)
+  ) where
+
+
+-- | Class for datatypes that represent data constructors.
+-- For non-symbolic constructors, only 'conName' has to be defined.
+-- The weird argument is supposed to be instantiated with 'C' from
+-- base, hence the complex kind.
+class Constructor c where
+  conName   :: t c (f :: * -> *) r -> String
+  conFixity :: t c (f :: * -> *) r -> Fixity
+  conFixity = const Prefix
+
+-- | Datatype to represent the fixity of a constructor. An infix declaration
+-- directly corresponds to an application of 'Infix'.
+data Fixity = Prefix | Infix Associativity Int
+  deriving (Eq, Show, Ord, Read)
+
+data Associativity = LeftAssociative | RightAssociative | NotAssociative
+  deriving (Eq, Show, Ord, Read)
diff --git a/src/Generics/Regular/Functions.hs b/src/Generics/Regular/Functions.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions.hs
@@ -0,0 +1,344 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic functionality for regular dataypes: mapM, flatten, zip,
+-- equality, show, value generation and fold.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions (
+
+  -- * Functorial map function
+  Functor (..),
+  
+  -- * Monadic functorial map function
+  GMap (..),
+  
+  -- * Crush right functions
+  CrushR (..),
+  flatten,
+
+  -- * Zip functions
+  Zip (..),
+  fzip,
+  fzip',
+
+  -- * Equality function
+  geq,
+
+  -- * Show function
+  GShow (..),
+  gshow,
+  
+  -- * Functions for generating values that are different on top-level
+  LRBase (..),
+  LR (..),
+  left,
+  right,
+  
+  -- * Generic folding
+  Alg, Algebra,
+  Fold, alg,
+  fold,
+  (&)  
+
+) where
+
+import Control.Monad
+
+import Generics.Regular.Base
+
+
+-----------------------------------------------------------------------------
+-- Monadic functorial map function.
+-----------------------------------------------------------------------------
+
+-- | The @GMap@ class defines a monadic functorial map.
+class GMap f where
+  fmapM :: Monad m => (a -> m b) -> f a -> m (f b)
+
+instance GMap I where
+  fmapM f (I r) = liftM I (f r)
+
+instance GMap (K a) where
+  fmapM _ (K x)  = return (K x)
+
+instance GMap U where
+  fmapM _ U = return U
+
+instance (GMap f, GMap g) => GMap (f :+: g) where
+  fmapM f (L x) = liftM L (fmapM f x)
+  fmapM f (R x) = liftM R (fmapM f x)
+
+instance (GMap f, GMap g) => GMap (f :*: g) where
+  fmapM f (x :*: y) = liftM2 (:*:) (fmapM f x) (fmapM f y)
+
+instance GMap f => GMap (C c f) where
+  fmapM f (C x) = liftM C (fmapM f x)
+
+
+-----------------------------------------------------------------------------
+-- CrushR functions.
+-----------------------------------------------------------------------------
+
+-- | The @CrushR@ class defines a right-associative crush on functorial values.
+class CrushR f where
+  crushr :: (a -> b -> b) -> b -> f a -> b
+
+instance CrushR I where
+  crushr op e (I x) = x `op` e
+
+instance CrushR (K a) where
+  crushr _ e _ = e
+
+instance CrushR U where
+  crushr _ e _ = e
+
+instance (CrushR f, CrushR g) => CrushR (f :+: g) where
+  crushr op e (L x) = crushr op e x
+  crushr op e (R y) = crushr op e y
+
+instance (CrushR f, CrushR g) => CrushR (f :*: g) where
+  crushr op e (x :*: y) = crushr op (crushr op e y) x
+
+instance CrushR f => CrushR (C c f) where
+  crushr op e (C x) = crushr op e x
+
+-- | Flatten a structure by collecting all the elements present.
+flatten :: CrushR f => f a -> [a]
+flatten = crushr (:) []
+
+
+-----------------------------------------------------------------------------
+-- Zip functions.
+-----------------------------------------------------------------------------
+
+-- | The @Zip@ class defines a monadic zip on functorial values.
+class Zip f where
+  fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)
+
+instance Zip I where
+  fzipM f (I x) (I y) = liftM I (f x y)
+
+instance Eq a => Zip (K a) where
+  fzipM _ (K x) (K y) 
+    | x == y    = return (K x)
+    | otherwise = fail "fzipM: structure mismatch"
+
+instance Zip U where
+  fzipM _ U U = return U
+
+instance (Zip f, Zip g) => Zip (f :+: g) where
+  fzipM f (L x) (L y) = liftM L (fzipM f x y)
+  fzipM f (R x) (R y) = liftM R (fzipM f x y)
+  fzipM _ _       _       = fail "fzipM: structure mismatch"
+
+instance (Zip f, Zip g) => Zip (f :*: g) where
+  fzipM f (x1 :*: y1) (x2 :*: y2) = 
+    liftM2 (:*:) (fzipM f x1 x2)
+                 (fzipM f y1 y2)
+
+instance Zip f => Zip (C c f) where
+  fzipM f (C x) (C y) = liftM C (fzipM f x y)
+
+-- | Functorial zip with a non-monadic function, resulting in a monadic value.
+fzip  :: (Zip f, Monad m) => (a -> b -> c) -> f a -> f b -> m (f c)
+fzip f = fzipM (\x y -> return (f x y))
+
+-- | Partial functorial zip with a non-monadic function.
+fzip' :: Zip f => (a -> b -> c) -> f a -> f b -> f c
+fzip' f x y = maybe (error "fzip': structure mismatch") id (fzip f x y)
+
+
+-----------------------------------------------------------------------------
+-- Equality function.
+-----------------------------------------------------------------------------
+
+-- | Equality on values based on their structural representation.
+geq :: (b ~ PF a, Regular a, CrushR b, Zip b) => a -> a -> Bool
+geq x y = maybe False (crushr (&&) True) (fzip geq (from x) (from y))
+
+
+-----------------------------------------------------------------------------
+-- Show function.
+-----------------------------------------------------------------------------
+
+-- | The @GShow@ class defines a show on values.
+class GShow f where
+  gshowf :: (a -> ShowS) -> f a -> ShowS
+
+instance GShow I where
+  gshowf f (I r) = f r
+
+instance Show a => GShow (K a) where
+  gshowf _ (K x) = shows x
+
+instance GShow U where
+  gshowf _ U = id
+
+instance (GShow f, GShow g) => GShow (f :+: g) where
+  gshowf f (L x) = gshowf f x
+  gshowf f (R x) = gshowf f x
+
+instance (GShow f, GShow g) => GShow (f :*: g) where
+  gshowf f (x :*: y) = gshowf f x . showChar ' ' . gshowf f y
+
+
+instance (Constructor c, GShow f) => GShow (C c f) where
+  gshowf f cx@(C x) = 
+    showParen True (showString (conName cx) . showChar ' ' . gshowf f x)
+
+
+gshow :: (Regular a, GShow (PF a)) => a -> ShowS
+gshow x = gshowf gshow (from x)
+
+-----------------------------------------------------------------------------
+-- Functions for generating values that are different on top-level.
+-----------------------------------------------------------------------------
+
+-- | The @LRBase@ class defines two functions, @leftb@ and @rightb@, which 
+-- should produce different values.
+class LRBase a where
+  leftb  :: a
+  rightb :: a
+
+instance LRBase Int where
+  leftb  = 0
+  rightb = 1
+
+instance LRBase Integer where
+  leftb  = 0
+  rightb = 1
+
+instance LRBase Char where
+  leftb  = 'L'
+  rightb = 'R'
+ 
+instance LRBase a => LRBase [a] where
+  leftb  = []
+  rightb = [error "Should never be inspected"]
+
+-- | The @LR@ class defines two functions, @leftf@ and @rightf@, which should 
+-- produce different functorial values.
+class LR f where
+  leftf  :: a -> f a
+  rightf :: a -> f a
+
+instance LR I where
+  leftf  x = I x
+  rightf x = I x
+
+instance LRBase a => LR (K a) where
+  leftf  _ = K leftb
+  rightf _ = K rightb
+
+instance LR U where
+  leftf  _ = U
+  rightf _ = U
+
+instance (LR f, LR g) => LR (f :+: g) where
+  leftf  x = L (leftf x)
+  rightf x = R (rightf x)
+
+instance (LR f, LR g) => LR (f :*: g) where
+  leftf  x = leftf x :*: leftf x
+  rightf x = rightf x :*: rightf x
+
+instance LR f => LR (C c f) where
+  leftf  x = C (leftf x)
+  rightf x = C (rightf x)
+
+-- | Produces a value which should be different from the value returned by 
+-- @right@.
+left :: (Regular a, LR (PF a)) => a
+left = to (leftf left)
+
+-- | Produces a value which should be different from the value returned by 
+-- @left@.
+right :: (Regular a, LR (PF a)) => a
+right = to (rightf right)
+
+
+-----------------------------------------------------------------------------
+-- Folds
+-----------------------------------------------------------------------------
+
+type family Alg (f :: (* -> *)) 
+                (r :: *) -- result type
+                :: *
+
+-- | For a constant, we take the constant value to a result.
+type instance Alg (K a) r = a -> r
+
+-- | For a unit, no arguments are available.
+type instance Alg U r = r
+
+-- | For an identity, we turn the recursive result into a final result.
+type instance Alg I r = r -> r
+
+-- | For a sum, the algebra is a pair of two algebras.
+type instance Alg (f :+: g) r = (Alg f r, Alg g r)
+
+-- | For a product where the left hand side is a constant, we
+--   take the value as an additional argument.
+type instance Alg (K a :*: g) r = a -> Alg g r
+
+-- | For a product where the left hand side is an identity, we
+--   take the recursive result as an additional argument.
+type instance Alg (I :*: g) r = r -> Alg g r
+
+-- | Constructors are ignored.
+type instance Alg (C c f) r = Alg f r
+
+
+type Algebra a r = Alg (PF a) r
+
+-- | The class fold explains how to convert an algebra
+--   'Alg' into a function from functor to result.
+class Fold (f :: * -> *) where
+  alg :: Alg f r -> f r -> r
+
+instance Fold (K a) where
+  alg f (K x) = f x
+
+instance Fold U where
+  alg f U     = f
+
+instance Fold I where
+  alg f (I x) = f x
+
+instance (Fold f, Fold g) => Fold (f :+: g) where
+  alg (f, _) (L x) = alg f x
+  alg (_, g) (R x) = alg g x
+
+instance (Fold g) => Fold (K a :*: g) where
+  alg f (K x :*: y) = alg (f x) y
+
+instance (Fold g) => Fold (I :*: g) where
+  alg f (I x :*: y) = alg (f x) y
+
+instance (Fold f) => Fold (C c f) where
+  alg f (C x) = alg f x
+
+-- | Fold with convenient algebras.
+fold :: (Regular a, Fold (PF a), Functor (PF a))
+     => Algebra a r -> a -> r
+fold f = alg f . fmap (\x -> fold f x) . from
+
+-- Construction of algebras
+infixr 5 &
+
+-- | For constructing algebras it is helpful to use this pairing combinator.
+(&) :: a -> b -> (a, b)
+(&) = (,)
diff --git a/src/Generics/Regular/TH.hs b/src/Generics/Regular/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/TH.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -w           #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.TH
+-- Copyright   :  (c) 2008--2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- This module contains Template Haskell code that can be used to
+-- automatically generate the boilerplate code for the regular
+-- library.
+--
+-----------------------------------------------------------------------------
+
+-- Adapted from Generics.Multirec.TH
+module Generics.Regular.TH
+  ( deriveConstructors,
+    deriveRegular,
+    derivePF
+  ) where
+
+import Generics.Regular.Base
+import Generics.Regular.Constructor
+import Language.Haskell.TH hiding (Fixity())
+import Language.Haskell.TH.Syntax (Lift(..))
+import Control.Monad
+
+-- | Given a datatype name, derive datatypes and 
+-- instances of class 'Constructor'.
+
+deriveConstructors :: Name -> Q [Dec]
+deriveConstructors = constrInstance
+
+-- | Given the type and the name (as string) for the
+-- pattern functor to derive, generate the 'Regular'
+-- instance.
+
+deriveRegular :: Name -> String -> Q [Dec]
+deriveRegular n pfn =
+  do
+    pf  <- derivePF pfn n
+    fam <- deriveInst n
+    return $ pf ++ fam
+
+-- | Derive only the 'PF' instance. Not needed if 'deriveRegular'
+-- is used.
+
+derivePF :: String -> Name -> Q [Dec]
+derivePF pfn n =
+    fmap (:[]) $
+    tySynD (mkName pfn) [] (pfType n)
+
+deriveInst :: Name -> Q [Dec]
+deriveInst t =
+  do
+    fcs <- mkFrom t 1 0 t
+    tcs <- mkTo   t 1 0 t
+    liftM (:[]) $
+      instanceD (cxt []) (conT ''Regular `appT` conT t)
+        [funD 'from fcs, funD 'to tcs]
+
+constrInstance :: Name -> Q [Dec]
+constrInstance n =
+  do
+    i <- reify n
+    -- runIO (print i)
+    let cs = case i of
+               TyConI (DataD _ _ _ cs _) -> cs
+               _ -> []
+    ds <- mapM mkData cs
+    is <- mapM mkInstance cs
+    return $ ds ++ is
+
+stripRecordNames :: Con -> Con
+stripRecordNames (RecC n f) =
+  NormalC n (map (\(_, s, t) -> (s, t)) f)
+stripRecordNames c = c
+
+mkData :: Con -> Q Dec
+mkData (NormalC n _) =
+  dataD (cxt []) (mkName (nameBase n)) [] [] [] 
+mkData r@(RecC _ _) =
+  mkData (stripRecordNames r)
+mkData (InfixC t1 n t2) =
+  mkData (NormalC n [t1,t2])
+
+instance Lift Fixity where
+  lift Prefix      = conE 'Prefix
+  lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
+
+instance Lift Associativity where
+  lift LeftAssociative  = conE 'LeftAssociative
+  lift RightAssociative = conE 'RightAssociative
+  lift NotAssociative   = conE 'NotAssociative
+
+mkInstance :: Con -> Q Dec
+mkInstance (NormalC n _) =
+    instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName (nameBase n)))
+      [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []]]
+mkInstance r@(RecC _ _) =
+  mkInstance (stripRecordNames r)
+mkInstance (InfixC t1 n t2) =
+    do
+      i <- reify n
+      let fi = case i of
+                 DataConI _ _ _ f -> convertFixity f
+                 _ -> Prefix
+      instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName (nameBase n)))
+        [funD 'conName   [clause [wildP] (normalB (stringE ("(" ++ (nameBase n) ++ ")"))) []],
+         funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
+  where
+    convertFixity (Fixity n d) = Infix (convertDirection d) n
+    convertDirection InfixL = LeftAssociative
+    convertDirection InfixR = RightAssociative
+    convertDirection InfixN = NotAssociative
+
+pfType :: Name -> Q Type
+pfType n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      i <- reify n
+      let b = case i of
+                TyConI (DataD _ _ _ cs _) ->
+                  foldr1 sum (map (pfCon n) cs)
+                TyConI (TySynD t _ _) ->
+                  conT ''K `appT` conT t
+                _ -> error "unknown construct" 
+      --appT b (conT $ mkName (nameBase n))
+      b
+  where
+    sum :: Q Type -> Q Type -> Q Type
+    sum a b = conT ''(:+:) `appT` a `appT` b
+
+pfCon :: Name -> Con -> Q Type
+pfCon ns (NormalC n []) =
+    appT (appT (conT ''C) (conT $ mkName (nameBase n))) (conT ''U)
+pfCon ns (NormalC n fs) =
+    appT (appT (conT ''C) (conT $ mkName (nameBase n))) (foldr1 prod (map (pfField ns . snd) fs))
+  where
+    prod :: Q Type -> Q Type -> Q Type
+    prod a b = conT ''(:*:) `appT` a `appT` b
+pfCon ns r@(RecC _ _) =
+  pfCon ns (stripRecordNames r)
+pfCon ns (InfixC t1 n t2) =
+    pfCon ns (NormalC n [t1,t2])
+
+pfField :: Name -> Type -> Q Type
+pfField ns t@(ConT n) | n == ns = conT ''I
+pfField ns t                    = conT ''K `appT` return t
+
+mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause]
+mkFrom ns m i n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      let wrapE e = lrE m i e
+      i <- reify n
+      let dn = mkName (nameBase n)
+      let b = case i of
+                TyConI (DataD _ _ _ cs _) ->
+                  zipWith (fromCon wrapE ns dn (length cs)) [0..] cs
+                TyConI (TySynD t _ _) ->
+                  [clause [varP (field 0)] (normalB (wrapE $ conE 'K `appE` varE (field 0))) []]
+                _ -> error "unknown construct"
+      return b
+
+mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause]
+mkTo ns m i n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      let wrapP p = lrP m i p
+      i <- reify n
+      let dn = mkName (nameBase n)
+      let b = case i of
+                TyConI (DataD _ _ _ cs _) ->
+                  zipWith (toCon wrapP ns dn (length cs)) [0..] cs
+                TyConI (TySynD t _ _) ->
+                  [clause [wrapP $ conP 'K [varP (field 0)]] (normalB $ varE (field 0)) []]
+                _ -> error "unknown construct" 
+      return b
+
+fromCon :: (Q Exp -> Q Exp) -> Name -> Name -> Int -> Int -> Con -> Q Clause
+fromCon wrap ns n m i (NormalC cn []) =
+    clause
+      [conP cn []]
+      (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []
+fromCon wrap ns n m i (NormalC cn fs) =
+    -- runIO (putStrLn ("constructor " ++ show ix)) >>
+    clause
+      [conP cn (map (varP . field) [0..length fs - 1])]
+      (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField ns) [0..] (map snd fs))) []
+  where
+    prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns n m i r@(RecC _ _) =
+  fromCon wrap ns n m i (stripRecordNames r)
+fromCon wrap ns n m i (InfixC t1 cn t2) =
+  fromCon wrap ns n m i (NormalC cn [t1,t2])
+
+toCon :: (Q Pat -> Q Pat) -> Name -> Name -> Int -> Int -> Con -> Q Clause
+toCon wrap ns n m i (NormalC cn []) =
+    clause
+      [wrap $ lrP m i $ conP 'C [conP 'U []]]
+      (normalB $ conE cn) []
+toCon wrap ns n m i (NormalC cn fs) =
+    -- runIO (putStrLn ("constructor " ++ show ix)) >>
+    clause
+      [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField ns) [0..] (map snd fs))]]
+      (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+  where
+    prod x y = conP '(:*:) [x,y]
+toCon wrap ns n m i r@(RecC _ _) =
+  toCon wrap ns n m i (stripRecordNames r)
+toCon wrap ns n m i (InfixC t1 cn t2) =
+  toCon wrap ns n m i (NormalC cn [t1,t2])
+
+fromField :: Name -> Int -> Type -> Q Exp
+fromField ns nr t@(ConT n) | n == ns = conE 'I `appE` varE (field nr)
+fromField ns nr t                    = conE 'K `appE` varE (field nr)
+
+toField :: Name -> Int -> Type -> Q Pat
+toField ns nr t@(ConT n) | n == ns = conP 'I [varP (field nr)]
+toField ns nr t                    = conP 'K [varP (field nr)]
+
+field :: Int -> Name
+field n = mkName $ "f" ++ show n
+
+lrP :: Int -> Int -> (Q Pat -> Q Pat)
+lrP 1 0 p = p
+lrP m 0 p = conP 'L [p]
+lrP m i p = conP 'R [lrP (m-1) (i-1) p]
+
+lrE :: Int -> Int -> (Q Exp -> Q Exp)
+lrE 1 0 e = e
+lrE m 0 e = conE 'L `appE` e
+lrE m i e = conE 'R `appE` lrE (m-1) (i-1) e
+