diff --git a/CREDITS b/CREDITS
new file mode 100644
--- /dev/null
+++ b/CREDITS
@@ -0,0 +1,24 @@
+Credits for regular
+===================
+
+This is a list of those who have contributed to the research, concept, code,
+and/or other issues of the regular library.
+
+Research and Code
+-----------------
+
+*  Thomas van Noort
+*  Alexey Rodriguez
+*  Stefan Holdermans
+*  Johan Jeuring
+*  Bastiaan Heeren
+
+Ideas and Support
+-----------------
+
+*  Thomas van Noort
+*  José Pedro Magalhães
+*  Andres Löh
+*  Rui Barbosa
+*  Erik Hesselink
+*  Sebastiaan Visser
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,10 @@
+version 0.2:
+  - Separated generic functions per modules
+  - Added generic unfold
+  - Added record selectors
+  - Improved generic show, added showsPrec
+  - Added generic read
+  - Added generic deep seq
+  - Added constructor names
+
+version 0.1: initial release
diff --git a/examples/Test.hs b/examples/Test.hs
--- a/examples/Test.hs
+++ b/examples/Test.hs
@@ -6,8 +6,12 @@
 module Test where
 
 import Generics.Regular
+import Generics.Regular.Functions
+import qualified Generics.Regular.Functions.Show as G
+import qualified Generics.Regular.Functions.Read as G
 
--- * Datatype representing logical expressions
+
+-- Datatype representing logical expressions
 data Logic = Var String
            | Logic :->:  Logic  -- implication
            | Logic :<->: Logic  -- equivalence
@@ -18,42 +22,53 @@
            | F                  -- false
            deriving Show
 
--- * Instantiating Regular for Logic using TH
--- ** Constructors
-$(deriveConstructors ''Logic)
-
--- ** Functor encoding and 'Regular' instance
-$(deriveRegular ''Logic "PFLogic")
+-- Instantiating Regular for Logic using TH
+$(deriveAll ''Logic "PFLogic")
 type instance PF Logic = PFLogic
 
--- * Example logical expressions
+-- Example logical expressions
 l1, l2, l3 :: Logic
 l1 = Var "p"
 l2 = Not l1
 l3 = l1 :->: l2
 
--- * Testing flattening
+-- Testing flattening
 ex0 :: [Logic]
-ex0 = flatten (from l3)
+ex0 = flattenr (from l3)
 
--- * Testing generic equality
+-- Testing generic equality
 ex1, ex2 :: Bool
-ex1 = geq l3 l3
-ex2 = geq l3 l2
+ex1 = eq l3 l3
+ex2 = eq l3 l2
 
--- * Testing generic show
+-- Testing generic show
 ex3 :: String
-ex3 = gshow l3 ""
+ex3 = G.show l3
 
--- * Testing value generation
-ex4, ex5 :: Logic
-ex4 = left
-ex5 = right
+-- Testing generic read
+ex4 :: Logic
+ex4 = G.read ex3
 
--- * Testing folding
-ex6 :: (String -> Bool) -> Logic -> Bool
-ex6 env = fold (env & impl & (==) & (&&) & (||) & not & True & False)
-  where impl p q = not p || q
+-- Testing value generation
+ex5, ex6 :: Logic
+ex5 = left
+ex6 = right
 
+-- Testing folding
 ex7 :: Bool
-ex7 = ex6 (\_ -> False) l3
+ex7 = fold (alg (\_ -> False)) l3 where
+  alg env = (env & impl & (==) & (&&) & (||) & not & True & False)
+  impl p q = not p || q
+
+-- Testing unfolding
+ex8 :: Int -> Logic
+ex8 n = unfold alg n where
+  alg :: CoAlgebra Logic Int
+  alg n | odd n || n <= 0 = Left ""
+        | even n          = Right (Left (n-1,n-2))
+
+-- Testing conNames
+ex9 = conNames (undefined :: Logic)
+
+-- Testing deep seq
+ex10 = gdseq (Not (T :->: (error "deep seq works"))) ()
diff --git a/regular.cabal b/regular.cabal
--- a/regular.cabal
+++ b/regular.cabal
@@ -1,5 +1,5 @@
 name:                   regular
-version:                0.1
+version:                0.2
 synopsis:               Generic programming library for regular datatypes.
 description:
 
@@ -18,31 +18,41 @@
   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>
+  \[1] <http://hackage.haskell.org/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
+author:                 Jose Pedro Magalhaes
 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
-
+                        ChangeLog
+                        CREDITS
 
 library
   hs-source-dirs:       src
   exposed-modules:      Generics.Regular
                         Generics.Regular.Base
-                        Generics.Regular.Functions
                         Generics.Regular.Constructor
+                        Generics.Regular.Selector
                         Generics.Regular.TH
+                        
+                        Generics.Regular.Functions
+                        Generics.Regular.Functions.ConNames
+                        Generics.Regular.Functions.Crush
+                        Generics.Regular.Functions.Eq
+                        Generics.Regular.Functions.Fold
+                        Generics.Regular.Functions.GMap
+                        Generics.Regular.Functions.LR
+                        Generics.Regular.Functions.Read
+                        Generics.Regular.Functions.Seq
+                        Generics.Regular.Functions.Show
+                        Generics.Regular.Functions.Zip
+                        
   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
--- a/src/Generics/Regular.hs
+++ b/src/Generics/Regular.hs
@@ -24,20 +24,109 @@
 -- >             | T                  -- true
 -- >             | F                  -- false
 --
--- An instance of @Regular@ is derived with TH by invoking:
+-- First we import the relevant modules:
 --
--- >  $(deriveConstructors ''Logic)
--- >  $(deriveRegular ''Logic "PFLogic")
--- >  type instance PF Logic = PFLogic
+-- > import Generics.Regular
+-- > import Generics.Regular.Functions
+-- > import qualified Generics.Regular.Functions.Show as G
+-- > import qualified Generics.Regular.Functions.Read as G
+--
+-- An instance of @Regular@ can be derived automatically with TH by invoking:
+--
+-- > $(deriveAll ''Logic "PFLogic")
+-- > type instance PF Logic = PFLogic
+--
+-- We define some logic expressions:
+--
+-- > l1, l2, l3 :: Logic
+-- > l1 = Var "p"
+-- > l2 = Not l1
+-- > l3 = l1 :->: l2
+--
+-- And now we can use all of the generic functions. Flattening:
+--
+-- > ex0 :: [Logic]
+-- > ex0 = flattenr (from l3)
+-- >
+-- > > [Var "p",Not (Var "p")]
+--
+-- Generic equality:
+--
+-- > ex1, ex2 :: Bool
+-- > ex1 = eq l3 l3
+-- >
+-- > > True
+-- >
+-- >
+-- > ex2 = eq l3 l2
+-- >
+-- > > False
+--
+-- Generic show:
+--
+-- > ex3 :: String
+-- > ex3 = G.show l3
+-- >
+-- > > "((:->:) (Var \"p\") (Not (Var \"p\")))"
+--
+-- Generic read:
+--
+-- > ex4 :: Logic
+-- > ex4 = G.read ex3
+-- >
+-- > > Var "p" :->: Not (Var "p")
+--
+-- Value generation:
+--
+-- > ex5, ex6 :: Logic
+-- > ex5 = left
+-- >
+-- > > Var ""
+-- >
+-- >
+-- > ex6 = right
+-- >
+-- > > F
+--
+-- Folding:
+--
+-- > ex7 :: Bool
+-- > ex7 = fold (alg (\_ -> False)) l3 where
+-- >   alg env = (env & impl & (==) & (&&) & (||) & not & True & False)
+-- >   impl p q = not p || q
+-- >
+-- > > True
+--
+-- Unfolding:
+--
+-- > ex8 :: Logic
+-- > ex8 = unfold alg 8 where
+-- >   alg :: CoAlgebra Logic Int
+-- >   alg n | odd n || n <= 0 = Left ""
+-- >         | even n          = Right (Left (n-1,n-2))
+-- >
+-- > > Var "" :->: (Var "" :->: (Var "" :->: (Var "" :->: Var "")))
+--
+-- Constructor names:
+--
+-- > ex9 = conNames (undefined :: Logic)
+-- >
+-- > > ["Var",":->:",":<->:",":&&:",":||:","Not","T","F"]
+--
+-- Deep seq:
+--
+-- > ex10 = gdseq (Not (T :->: (error "deep seq works"))) ()
+-- >
+-- > > *** Exception: deep seq works
 -- 
 -----------------------------------------------------------------------------
 
 module Generics.Regular (
     module Generics.Regular.Base,
-    module Generics.Regular.Functions,
-    module Generics.Regular.TH
+    module Generics.Regular.TH,
+    module Generics.Regular.Functions
   ) where
 
 import Generics.Regular.Base
-import Generics.Regular.Functions
 import Generics.Regular.TH
+import Generics.Regular.Functions
diff --git a/src/Generics/Regular/Base.hs b/src/Generics/Regular/Base.hs
--- a/src/Generics/Regular/Base.hs
+++ b/src/Generics/Regular/Base.hs
@@ -24,7 +24,10 @@
     (:+:)(..),
     (:*:)(..),
     C(..),
+    S(..),
+
     Constructor(..), Fixity(..), Associativity(..),
+    Selector(..), 
 
     -- * Fixed-point type
     Fix (..),
@@ -35,6 +38,7 @@
   ) where
 
 import Generics.Regular.Constructor
+import Generics.Regular.Selector
 
 
 -----------------------------------------------------------------------------
@@ -59,6 +63,9 @@
 -- | Structure type to store the name of a constructor.
 data C c f r =  C { unC :: f r }
 
+-- | Structure type to store the name of a record selector.
+data S l f r =  S { unS :: f r }
+
 infixr 6 :+:
 infixr 7 :*:
 
@@ -67,7 +74,7 @@
 -----------------------------------------------------------------------------
 
 -- | The well-known fixed-point type.
-newtype Fix f = In (f (Fix f))
+newtype Fix f = In { out :: f (Fix f) }
 
 
 -----------------------------------------------------------------------------
@@ -111,3 +118,7 @@
 
 instance Functor f => Functor (C c f) where
   fmap f (C r) = C (fmap f r)
+
+instance Functor f => Functor (S c f) where
+  fmap f (S r) = S (fmap f r)
+
diff --git a/src/Generics/Regular/Constructor.hs b/src/Generics/Regular/Constructor.hs
--- a/src/Generics/Regular/Constructor.hs
+++ b/src/Generics/Regular/Constructor.hs
@@ -26,6 +26,8 @@
   conName   :: t c (f :: * -> *) r -> String
   conFixity :: t c (f :: * -> *) r -> Fixity
   conFixity = const Prefix
+  conIsRecord :: t c (f :: * -> *) r -> Bool
+  conIsRecord = const False
 
 -- | Datatype to represent the fixity of a constructor. An infix declaration
 -- directly corresponds to an application of 'Infix'.
diff --git a/src/Generics/Regular/Functions.hs b/src/Generics/Regular/Functions.hs
--- a/src/Generics/Regular/Functions.hs
+++ b/src/Generics/Regular/Functions.hs
@@ -13,332 +13,46 @@
 -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- Summary: Generic functionality for regular dataypes: mapM, flatten, zip,
--- equality, show, value generation and fold.
+-- Summary: All of the generic functionality for regular dataypes: mapM, 
+-- flatten, zip, equality, value generation, fold and unfold.
+-- Generic show ("Generics.Regular.Functions.Show") and generic read 
+-- ("Generics.Regular.Functions.Read") are not exported to prevent clashes
+-- with @Prelude@.
 -----------------------------------------------------------------------------
 
 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
+    -- * Constructor names
+    module Generics.Regular.Functions.ConNames,
+    
+    -- * Crush
+    module Generics.Regular.Functions.Crush,
+    
+    -- * Equality
+    module Generics.Regular.Functions.Eq,
+    
+    -- * Generic folding
+    module Generics.Regular.Functions.Fold,
+    
+    -- * Functorial map
+    module Generics.Regular.Functions.GMap,
+    
+    -- * Generating values that are different on top-level
+    module Generics.Regular.Functions.LR,
+    
+    -- * Deep seq
+    module Generics.Regular.Functions.Seq,
+    
+    -- * Zipping
+    module Generics.Regular.Functions.Zip
 
--- Construction of algebras
-infixr 5 &
+  ) where
 
--- | For constructing algebras it is helpful to use this pairing combinator.
-(&) :: a -> b -> (a, b)
-(&) = (,)
+import Generics.Regular.Functions.ConNames
+import Generics.Regular.Functions.Crush
+import Generics.Regular.Functions.Eq
+import Generics.Regular.Functions.Fold
+import Generics.Regular.Functions.GMap
+import Generics.Regular.Functions.LR
+import Generics.Regular.Functions.Seq
+import Generics.Regular.Functions.Zip
diff --git a/src/Generics/Regular/Functions/ConNames.hs b/src/Generics/Regular/Functions/ConNames.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/ConNames.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE FlexibleContexts      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.ConNames
+-- Copyright   :  (c) 2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Return the name of all the constructors of a type.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.ConNames (
+
+    -- * Functionality for retrieving the names of all the possible contructors
+    --   of a type
+    ConNames(..), conNames
+
+  ) where
+
+import Generics.Regular.Base
+
+class ConNames f where 
+    hconNames :: f a -> [String]
+
+instance (ConNames f, ConNames g) => ConNames (f :+: g) where
+    hconNames (_ :: (f :+: g) a) = hconNames (undefined :: f a) ++
+                                   hconNames (undefined :: g a)
+    
+instance (ConNames f, Constructor c) => ConNames (C c f) where
+    hconNames (x :: (C c f) a) = [conName x]
+
+instance (ConNames f, ConNames g) => ConNames (f :*: g) where
+    hconNames _ = []
+
+instance ConNames I where
+    hconNames _ = []
+
+instance ConNames U where
+    hconNames _ = []
+
+instance ConNames (K a) where
+    hconNames _ = []
+
+-- | Return the name of all the constructors of the type of the given term.
+conNames :: (Regular a, ConNames (PF a)) => a -> [String]
+conNames x = hconNames (undefined `asTypeOf` (from x))
+
+-------------------------------------------------------------------------------- 
diff --git a/src/Generics/Regular/Functions/Crush.hs b/src/Generics/Regular/Functions/Crush.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Crush.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TypeOperators     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Crush
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic crush.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Crush (
+
+  -- * Crush functions
+  Crush (..),
+  flattenl, flattenr, crushr, crushl
+
+) where
+
+import Generics.Regular.Base
+
+
+-----------------------------------------------------------------------------
+-- Crush functions.
+-----------------------------------------------------------------------------
+
+-- | Associativity of the binary operator used for 'crush'
+data Assoc = AssocLeft  -- ^ Left-associative
+           | AssocRight -- ^ Right-associative
+
+
+-- | The @Crush@ class defines a right-associative crush on functorial values.
+class Crush f where
+  crush :: Assoc -> (a -> b -> b) -> b -> f a -> b
+
+instance Crush I where
+  crush _ op e (I x) = x `op` e
+
+instance Crush (K a) where
+  crush _ _ e _ = e
+
+instance Crush U where
+  crush _ _ e _ = e
+
+instance (Crush f, Crush g) => Crush (f :+: g) where
+  crush asc op e (L x) = crush asc op e x
+  crush asc op e (R y) = crush asc op e y
+
+instance (Crush f, Crush g) => Crush (f :*: g) where
+  crush asc@AssocRight op e (x :*: y) = crush asc op (crush asc op e y) x
+  crush asc@AssocLeft  op e (x :*: y) = crush asc op (crush asc op e x) y
+
+instance Crush f => Crush (C c f) where
+  crush asc op e (C x) = crush asc op e x
+
+instance Crush f => Crush (S s f) where
+  crush asc op e (S x) = crush asc op e x
+
+-- | Flatten a structure by collecting all the elements present.
+flattenr, flattenl :: Crush f => f a -> [a]
+flattenr = crushr (:) []
+flattenl = crushl (:) []
+
+crushr, crushl :: Crush f => (a -> b -> b) -> b -> f a -> b
+crushr = crush AssocRight
+crushl = crush AssocLeft
diff --git a/src/Generics/Regular/Functions/Eq.hs b/src/Generics/Regular/Functions/Eq.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Eq.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Eq
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic equality.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Eq (
+  
+  -- * Generic equality
+  Eq(..), eq
+  
+) where
+
+import Generics.Regular.Base
+import Prelude hiding (Eq)
+import qualified Prelude as P (Eq)
+
+
+class Eq f where
+  eqf :: (a -> a -> Bool) -> f a -> f a -> Bool
+
+instance Eq I where
+  eqf f (I x) (I y) = f x y
+
+instance P.Eq a => Eq (K a) where
+  eqf _ (K x) (K y) = x == y
+
+instance Eq U where
+  eqf _ U U = True
+
+instance (Eq f, Eq g) => Eq (f :+: g) where
+  eqf f (L x) (L y) = eqf f x y
+  eqf f (R x) (R y) = eqf f x y
+  eqf _ _     _     = False
+
+instance (Eq f, Eq g) => Eq (f :*: g) where
+  eqf f (x1 :*: y1) (x2 :*: y2) = eqf f x1 x2 && eqf f y1 y2
+
+instance Eq f => Eq (C c f) where
+  eqf f (C x) (C y) = eqf f x y
+
+eq :: (Regular a, Eq (PF a)) => a -> a -> Bool
+eq x y = eqf eq (from x) (from y)
diff --git a/src/Generics/Regular/Functions/Fold.hs b/src/Generics/Regular/Functions/Fold.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Fold.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Fold
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic folding and unfolding.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Fold (
+
+  -- * Generic folding
+  Alg, Algebra,
+  Fold, alg,
+  fold,
+  
+  -- * Generic unfolding
+  CoAlg, CoAlgebra,
+  Unfold, coalg,
+  unfold,
+  
+  -- * Construction of algebras
+  (&)  
+
+) where
+
+import Generics.Regular.Base
+
+
+-----------------------------------------------------------------------------
+-- 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
+type instance Alg (S s (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
+
+-- | Selectors are ignored.
+type instance Alg (S s 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
+
+instance (Fold f) => Fold (S s f) where
+  alg f (S 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
+
+-----------------------------------------------------------------------------
+-- Unfolds
+-----------------------------------------------------------------------------
+
+type family CoAlg (f :: (* -> *)) 
+                  (s :: *) -- seed type
+                  :: *
+
+-- | For a constant, we produce a constant value as a result.
+type instance CoAlg (K a) s = a
+
+-- | For an identity, we produce a new seed to create the recursive result.
+type instance CoAlg I s = s
+
+-- | Units can only produce units, so we use the singleton type to encode the
+-- lack of choice.
+type instance CoAlg U s = ()
+
+-- | For a sum, the coalgebra produces either the left or the right side. 
+type instance CoAlg (f :+: g) s = Either (CoAlg f s) (CoAlg g s)
+
+-- | For a produt, the coalgebra is a pair of the two arms.
+type instance CoAlg (f :*: g) s = (CoAlg f s, CoAlg g s)
+
+-- | Constructors are ignored.
+type instance CoAlg (C c f) s = CoAlg f s
+
+-- | Selectors are ignored.
+type instance CoAlg (S r f) s = CoAlg f s
+
+type CoAlgebra a s = s -> CoAlg (PF a) s
+
+-- | The class unfold explains how to convert a coalgebra 'CoAlg' and a seed
+-- into a representation.
+class Unfold (f :: * -> *) where
+  coalg :: (s -> a) -> CoAlg f s -> f a
+
+instance Unfold (K a) where
+  coalg _ = K
+
+instance Unfold I where
+  coalg r a = I (r a)
+  
+instance Unfold U where
+  coalg _ _ = U
+
+instance (Unfold f, Unfold g) => Unfold (f :+: g) where
+  coalg r (Left  c) = L (coalg r c)
+  coalg r (Right c) = R (coalg r c)
+
+instance (Unfold f, Unfold g) => Unfold (f :*: g) where
+  coalg r (c, g) = coalg r c :*: coalg r g
+
+instance Unfold f => Unfold (C c f) where
+  coalg r = C . coalg r
+
+instance Unfold f => Unfold (S s f) where
+  coalg r = S . coalg r
+
+unfold :: (Unfold (PF a), Regular a) => CoAlgebra a s -> s -> a
+unfold a = to . coalg (unfold a) . a
+
+-----------------------------------------------------------------------------
+
+-- 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/Functions/GMap.hs b/src/Generics/Regular/Functions/GMap.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/GMap.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE TypeOperators     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.GMap
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Monadic generic map.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.GMap (
+
+  -- * Functorial map function
+  Functor (..),
+  
+  -- * Monadic functorial map function
+  GMap (..)
+
+) 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)
+
+instance GMap f => GMap (S s f) where
+  fmapM f (S x) = liftM S (fmapM f x)
diff --git a/src/Generics/Regular/Functions/LR.hs b/src/Generics/Regular/Functions/LR.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/LR.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.LR
+-- 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.LR (
+
+  -- * Functions for generating values that are different on top-level
+  LRBase (..),
+  LR (..),
+  left,
+  right,
+
+) where
+
+import Generics.Regular.Base
+
+
+-----------------------------------------------------------------------------
+-- 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 = [rightb]
+
+-- | 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)
+
+instance LR f => LR (S s f) where
+  leftf  x = S (leftf x)
+  rightf x = S (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)
diff --git a/src/Generics/Regular/Functions/Read.hs b/src/Generics/Regular/Functions/Read.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Read.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Read
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic read. This module is not exported by 
+-- "Generics.Regular.Functions" to avoid clashes with "Prelude".
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Read (
+
+    -- * Read functions
+    Read(..),
+    read, readPrec, readsPrec
+
+) where
+
+-----------------------------------------------------------------------------
+-- Generic read.
+-----------------------------------------------------------------------------
+
+import Generics.Regular.Base
+
+import Data.Char
+import Control.Monad
+import Text.Read hiding (readsPrec, readPrec, read, Read)
+import Prelude hiding (readsPrec, read, Read)
+import qualified Prelude as P (readsPrec, Read)
+import Text.Read.Lex
+import Text.ParserCombinators.ReadPrec
+
+-- * Count the number of terms in a product
+
+class CountAtoms f where 
+  countatoms :: f r -> Int
+
+instance CountAtoms (K a) where
+  countatoms _ = 1
+
+instance CountAtoms I where
+  countatoms _ = 1
+
+instance (CountAtoms f, CountAtoms g) => CountAtoms (f :*: g) where
+  countatoms (_ :: (f :*: g) r) = countatoms (undefined :: f r) 
+                                + countatoms (undefined :: g r)
+
+instance CountAtoms f => CountAtoms (S s f) where
+  countatoms (_ :: S s f r) = countatoms (undefined :: f r)
+
+-- * Generic read
+
+class Read f where
+   hreader :: ReadPrec a -> Bool -> ReadPrec (f a)
+
+
+instance Read U where
+   hreader _ _ = return U
+
+instance (P.Read a) => Read (K a) where
+   hreader _ _ = liftM K (readS_to_Prec P.readsPrec)
+
+instance Read I where
+   hreader f _ = liftM I f
+
+instance (Read f, Read g) => Read (f :+: g) where
+   hreader f r = liftM L (hreader f r) +++ liftM R (hreader f r)
+
+instance (Read f, Read g) => Read (f :*: g) where
+   hreader f r = do l' <- hreader f r
+                    when r $ do Punc "," <- lexP
+                                return ()
+                    r' <- hreader f r
+                    return (l' :*: r')
+
+
+
+-- Dealing with constructors
+-- No arguments
+instance (Constructor c) => Read (C c U) where
+   hreader f _ = let constr = undefined :: C c U r
+                     name   = conName constr
+                 in readCons (readNoArgsCons f name)
+
+-- 1 argument
+instance (Constructor c, Read I) => Read (C c I) where
+   hreader f _ = let constr = undefined :: C c I r
+                     name   = conName constr
+                 in  readCons (readPrefixCons f True False name)
+
+instance (Constructor c, Read (K a)) => Read (C c (K a)) where
+   hreader f _ = let constr = undefined :: C c (K a) r
+                     name   = conName constr
+                 in  readCons (readPrefixCons f True False name) 
+
+instance (Constructor c, Read (S s f)) => Read (C c (S s f)) where
+   hreader f _ = let constr = undefined :: C c (K a) r
+                     name   = conName constr
+                 in  readCons (readPrefixCons f True True name)
+
+-- 2 arguments or more
+instance (Constructor c, CountAtoms (f :*: g), Read f, Read g) 
+         => Read (C c (f:*:g)) where
+   hreader f _ = let constr = undefined :: C c (f:*:g) r
+                     name   = conName constr
+                     fixity = conFixity constr
+                     isRecord = conIsRecord constr
+                     (assoc,prc,isInfix) = case fixity of 
+                                             Prefix    -> (LeftAssociative, 9, False)
+                                             Infix a p -> (a, p, True)
+                     nargs  = countatoms (undefined :: (f :*: g) r)
+                 in  readCons $ readPrefixCons f (not isInfix) isRecord name
+                                         +++
+                                (do guard (nargs == 2)
+                                    readInfixCons f (assoc,prc,isInfix) name
+                                )
+
+
+readCons :: (Constructor c) => ReadPrec (f a) -> ReadPrec (C c f a)
+readCons = liftM C
+
+readPrefixCons :: (Read f) 
+               => ReadPrec a -> Bool -> Bool -> String -> ReadPrec (f a)
+readPrefixCons f b r name = parens . prec appPrec $
+                            do parens (prefixConsNm name b) 
+                               step $ if r then braces (hreader f) else hreader f False
+    where prefixConsNm s True  = do Ident n <- lexP
+                                    guard (s == n)
+          prefixConsNm s False = do Punc "(" <-lexP
+                                    Symbol n <- lexP
+                                    guard (s == n)
+                                    Punc ")" <- lexP
+                                    return ()
+
+braces :: (Bool -> ReadPrec a) -> ReadPrec a
+braces f = do hasBraces <- try $ do {Punc "{" <- lexP; return ()}
+              res <- f hasBraces
+              when hasBraces $ do {Punc "}" <- lexP; return ()}
+              return res
+           where
+             try p = (p >> return True) `mplus` return False
+
+
+readInfixCons :: (Read f, Read g)
+              => ReadPrec a -> (Associativity,Int,Bool) -> String -> ReadPrec ((f :*: g) a)
+readInfixCons f (asc,prc,b) name = parens . prec prc $
+                                       do x <- {- (if asc == LeftAssociative  then id else step) -} step (hreader f False)
+                                          parens (infixConsNm name b)
+                                          y <- (if asc == RightAssociative then id else step) (hreader f False)
+                                          return  (x :*: y)
+     where  infixConsNm s True  = do Symbol n <- lexP
+                                     guard (n == s) 
+            infixConsNm s False = do Punc "`"  <- lexP
+                                     Ident n   <- lexP
+                                     guard (n == s)
+                                     Punc "`"  <- lexP
+                                     return ()
+
+readNoArgsCons :: ReadPrec a -> String -> ReadPrec (U a)
+readNoArgsCons _ name = parens $ 
+                             do Ident n <- lexP
+                                guard (n == name)
+                                return U
+
+appPrec :: Prec
+appPrec = 10
+
+instance (Selector s, Read f) => Read (S s f) where
+   hreader f r = do when r $ do Ident n <- lexP
+                                guard (n == selName (undefined :: S s f a))
+                                Punc "=" <- lexP
+                                return ()
+                    liftM S (hreader f r)
+
+
+-- Exported functions
+
+readPrec :: (Regular a, Read (PF a)) => ReadPrec a
+readPrec = liftM to (hreader readPrec False)
+
+readsPrec :: (Regular a, Read (PF a)) => Int -> ReadS a
+readsPrec n = readPrec_to_S readPrec n
+
+read :: (Regular a, Read (PF a)) => String -> a
+read s = case [x |  (x,remain) <- readsPrec 0 s , all isSpace remain] of
+           [x] -> x 
+           [ ] -> error "no parse"
+           _   -> error "ambiguous parse"
diff --git a/src/Generics/Regular/Functions/Seq.hs b/src/Generics/Regular/Functions/Seq.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Seq.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE FlexibleContexts         #-}
+{-# LANGUAGE FlexibleInstances        #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Seq
+-- Copyright   :  (c) 2009 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Deep generic seq. Used to fully evaluate a term.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Seq (
+
+    DeepSeq (..), Seq(..), gdseq
+    
+  ) where
+
+import Data.List
+import Generics.Regular.Base
+
+-- | The class for generic deep seq.
+class Seq f where
+  gseq :: (a -> b -> b) -> f a -> b -> b
+
+instance Seq I where
+  gseq f (I x) = f x
+
+-- | For constants we rely on the |DeepSeq| class.
+instance (DeepSeq a) => Seq (K a) where
+  gseq _ (K x) = dseq x
+  
+instance Seq U where
+  gseq _ U = id
+
+instance (Seq f, Seq g) => Seq (f :+: g) where
+  gseq f (L x) = gseq f x
+  gseq f (R y) = gseq f y
+
+instance (Seq f, Seq g) => Seq (f :*: g) where
+  gseq f (x :*: y) = gseq f x . gseq f y
+
+instance Seq f => Seq (C c f) where
+  gseq f (C x) = gseq f x
+
+instance Seq f => Seq (S s f) where
+  gseq f (S x) = gseq f x
+
+-- | Deep, generic version of seq.
+
+gdseq :: (Regular a, Seq (PF a)) => a -> b -> b
+gdseq p = gseq gdseq (from p)
+
+-- | A general class for expressing deep seq. It is used in the 'K' case for
+-- the generic seq.
+--
+-- We do not give an instance of the form
+-- @instance (Regular a, Seq (PF a)) => DeepSeq a where dseq = gdseq@
+-- because this requires undecidable instances. However, any type for which
+-- there is a generic instance can be given a trivial instance of 'DeepSeq' by
+-- using 'gdseq'.
+class DeepSeq a where
+  dseq   :: a -> b -> b
+  dseq = seq
+
+instance DeepSeq Int
+instance DeepSeq Integer
+instance DeepSeq Char
+instance DeepSeq Float
+instance DeepSeq Double
+instance DeepSeq ()
+
+instance DeepSeq a => DeepSeq [a] where
+  dseq xs b = foldl' (flip dseq) b xs
+
+instance DeepSeq a => DeepSeq (Maybe a) where
+  dseq Nothing  b = b
+  dseq (Just a) b = dseq a b
+
+instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b) where
+  dseq (Left  x) b = dseq x b
+  dseq (Right x) b = dseq x b
diff --git a/src/Generics/Regular/Functions/Show.hs b/src/Generics/Regular/Functions/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Show.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Show
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic show. This module is not exported by 
+-- "Generics.Regular.Functions" to avoid clashes with "Prelude".
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Show (
+
+  -- * Show function
+  Show (..),
+  show, shows
+
+) where
+
+import Generics.Regular.Base
+import Prelude hiding (Show, show, shows, showsPrec)
+import qualified Prelude as P (Show, showsPrec)
+
+
+-----------------------------------------------------------------------------
+-- Show function.
+-----------------------------------------------------------------------------
+
+-- | The @Show@ class defines a show on values.
+class Show f where
+  hshowsPrec :: (Int -> a -> ShowS) -> Bool -> Int -> f a -> ShowS
+
+instance Show I where
+  hshowsPrec f _ n (I r) = f n r
+
+instance (P.Show a) => Show (K a) where
+  hshowsPrec _ _ n (K x) = P.showsPrec n x
+
+instance Show U where
+  hshowsPrec _ _ _ U = id
+
+instance (Show f, Show g) => Show (f :+: g) where
+  hshowsPrec f b n (L x) = hshowsPrec f b n x
+  hshowsPrec f b n (R x) = hshowsPrec f b n x
+
+instance (Show f, Show g) => Show (f :*: g) where
+  hshowsPrec f b n (x :*: y) = hshowsPrec f b n x 
+                             . (if b then showString ", " else showString " ")
+                             . hshowsPrec f b n y
+
+instance (Constructor c, Show f) => Show (C c f) where
+  hshowsPrec f _ n cx@(C x) = case fixity of
+    Prefix -> showParen True (showString (conName cx) . showChar ' '                              . showBraces isRecord (hshowsPrec f isRecord n x))
+    Infix _ _ -> showParen True 
+                    (showChar '(' . showString (conName cx) 
+                     . showChar ')' . showChar ' ' 
+                     . showBraces isRecord (hshowsPrec f isRecord n x))
+    where isRecord = conIsRecord cx
+          fixity   = conFixity cx
+
+showBraces       :: Bool -> ShowS -> ShowS
+showBraces b p   =  if b then showChar '{' . p . showChar '}' else p
+
+instance (Selector s, Show f) => Show (S s f) where
+  hshowsPrec f b n s@(S x) = showString (selName s) . showString " = " 
+                           . hshowsPrec f b n x
+
+
+showsPrec :: (Regular a, Show (PF a)) => Int -> a -> ShowS
+showsPrec n x = hshowsPrec showsPrec False n (from x)
+
+shows :: (Regular a, Show (PF a)) => a -> ShowS
+shows = showsPrec 0
+
+show :: (Regular a, Show (PF a)) => a -> String
+show x = shows x ""
diff --git a/src/Generics/Regular/Functions/Zip.hs b/src/Generics/Regular/Functions/Zip.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Functions/Zip.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE TypeOperators     #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Functions.Zip
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Generic zip.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Functions.Zip (
+
+  -- * Zip functions
+  Zip (..),
+  fzip,
+  fzip'
+
+) where
+
+import Control.Monad (liftM, liftM2)
+
+import Generics.Regular.Base
+
+
+-----------------------------------------------------------------------------
+-- 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)
+
+instance Zip f => Zip (S s f) where
+  fzipM f (S x) (S y) = liftM S (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)
diff --git a/src/Generics/Regular/Selector.hs b/src/Generics/Regular/Selector.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Regular/Selector.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE KindSignatures #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Regular.Selector
+-- Copyright   :  (c) 2008 Universiteit Utrecht
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Representation for record selectors.
+-----------------------------------------------------------------------------
+
+module Generics.Regular.Selector (Selector(..)) where
+
+class Selector s where
+  selName   :: t s (f :: * -> *) r -> String
+
diff --git a/src/Generics/Regular/TH.hs b/src/Generics/Regular/TH.hs
--- a/src/Generics/Regular/TH.hs
+++ b/src/Generics/Regular/TH.hs
@@ -19,23 +19,43 @@
 
 -- Adapted from Generics.Multirec.TH
 module Generics.Regular.TH
-  ( deriveConstructors,
+  ( deriveAll,
+    deriveConstructors,
+    deriveSelectors,
     deriveRegular,
     derivePF
   ) where
 
+import Data.List (intercalate)
 import Generics.Regular.Base
 import Generics.Regular.Constructor
 import Language.Haskell.TH hiding (Fixity())
 import Language.Haskell.TH.Syntax (Lift(..))
 import Control.Monad
 
+-- | Given the type and the name (as string) for the pattern functor to derive,
+-- generate the Constructor' instances, the Selector' instances and the
+-- 'Regular' instance.
+
+deriveAll :: Name -> String -> Q [Dec]
+deriveAll n s =
+  do a <- deriveConstructors n
+     b <- deriveSelectors n
+     c <- deriveRegular n s
+     return (a ++ b ++ c)
+
 -- | Given a datatype name, derive datatypes and 
 -- instances of class 'Constructor'.
 
 deriveConstructors :: Name -> Q [Dec]
 deriveConstructors = constrInstance
 
+-- | Given a datatype name, derive datatypes and 
+-- instances of class 'Selector'.
+
+deriveSelectors :: Name -> Q [Dec]
+deriveSelectors = selectInstance
+
 -- | Given the type and the name (as string) for the
 -- pattern functor to derive, generate the 'Regular'
 -- instance.
@@ -52,43 +72,75 @@
 
 derivePF :: String -> Name -> Q [Dec]
 derivePF pfn n =
-    fmap (:[]) $
-    tySynD (mkName pfn) [] (pfType n)
+  do
+    i <- reify n
+    fmap (:[]) $ tySynD (mkName pfn) (typeVariables i) (pfType n)
 
 deriveInst :: Name -> Q [Dec]
 deriveInst t =
   do
+    i <- reify t
+    let typ = foldl (\a -> AppT a . VarT) (ConT t) (typeVariables i)
     fcs <- mkFrom t 1 0 t
     tcs <- mkTo   t 1 0 t
     liftM (:[]) $
-      instanceD (cxt []) (conT ''Regular `appT` conT t)
+      instanceD (cxt []) (conT ''Regular `appT` return typ)
         [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
+    case i of
+      TyConI (DataD    _ n _ cs _) -> mkInstance n cs
+      TyConI (NewtypeD _ n _ c  _) -> mkInstance n [c]
+      _ -> return []
+   where
+     mkInstance n cs = do
+       ds <- mapM (mkConstrData n) cs
+       is <- mapM (mkConstrInstance n) cs
+       return $ ds ++ is
 
+selectInstance :: Name -> Q [Dec]
+selectInstance n =
+  do
+    i <- reify n
+    case i of
+      TyConI (DataD    _ n _ cs _) -> mkInstance n cs
+      TyConI (NewtypeD _ n _ c  _) -> mkInstance n [c]
+      _ -> return []
+  where
+    mkInstance n cs = do
+      ds <- mapM (mkSelectData n) cs
+      is <- mapM (mkSelectInstance n) cs
+      return $ concat (ds ++ is)
+
+typeVariables :: Info -> [Name]
+typeVariables (TyConI (DataD    _ _ tv _ _)) = tv
+typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
+typeVariables _                           = []
+
 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])
+genName :: [Name] -> Name
+genName = mkName . (++"_") . intercalate "_" . map nameBase
 
+mkConstrData :: Name -> Con -> Q Dec
+mkConstrData dt (NormalC n _) =
+  dataD (cxt []) (genName [dt, n]) [] [] [] 
+mkConstrData dt r@(RecC _ _) =
+  mkConstrData dt (stripRecordNames r)
+mkConstrData dt (InfixC t1 n t2) =
+  mkConstrData dt (NormalC n [t1,t2])
+
+mkSelectData :: Name -> Con -> Q [Dec]
+mkSelectData dt r@(RecC n fs) = return (map one fs)
+  where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] []
+mkSelectData dt _ = return []
+
 instance Lift Fixity where
   lift Prefix      = conE 'Prefix
   lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |]
@@ -98,20 +150,18 @@
   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) =
+mkConstrInstance :: Name -> Con -> Q Dec
+mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n []
+mkConstrInstance dt (RecC    n _) = mkConstrInstanceWith dt n
+      [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]]
+mkConstrInstance dt (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) ++ ")"))) []],
+      instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+        [funD 'conName   [clause [wildP] (normalB (stringE (nameBase n))) []],
          funD 'conFixity [clause [wildP] (normalB [| fi |]) []]]
   where
     convertFixity (Fixity n d) = Infix (convertDirection d) n
@@ -119,14 +169,29 @@
     convertDirection InfixR = RightAssociative
     convertDirection InfixN = NotAssociative
 
+mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec
+mkConstrInstanceWith dt n extra = 
+    instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n]))
+      (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)
+
+mkSelectInstance :: Name -> Con -> Q [Dec]
+mkSelectInstance dt r@(RecC n fs) = return (map one fs)
+  where
+    one (f, _, _) = 
+      InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f]))
+        [FunD 'selName [Clause [WildP] (NormalB (LitE (StringL (nameBase f)))) []]]
+mkSelectInstance _ _ = return []
+
 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 (DataD _ dt vs cs _) ->
+                  foldr1 sum (map (pfCon (dt, vs)) cs)
+                TyConI (NewtypeD _ dt vs c _) ->
+                  pfCon (dt, vs) c
                 TyConI (TySynD t _ _) ->
                   conT ''K `appT` conT t
                 _ -> error "unknown construct" 
@@ -136,33 +201,48 @@
     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))
+
+pfCon :: (Name, [Name]) -> Con -> Q Type
+pfCon (dt, vs) (NormalC n []) =
+    appT (appT (conT ''C) (conT $ genName [dt, n])) (conT ''U)
+pfCon (dt, vs) (NormalC n fs) =
+    appT (appT (conT ''C) (conT $ genName [dt, n])) (foldr1 prod (map (pfField (dt, vs) . 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])
+pfCon (dt, vs) r@(RecC n []) =
+    appT (appT (conT ''C) (conT $ genName [dt, n])) (conT ''U)
+pfCon (dt, vs) r@(RecC n fs) =
+    appT (appT (conT ''C) (conT $ genName [dt, n])) (foldr1 prod (map (pfField' (dt, vs) n) fs))
+  where
+    prod :: Q Type -> Q Type -> Q Type
+    prod a b = conT ''(:*:) `appT` a `appT` b
 
-pfField :: Name -> Type -> Q Type
-pfField ns t@(ConT n) | n == ns = conT ''I
-pfField ns t                    = conT ''K `appT` return t
+pfCon d (InfixC t1 n t2) =
+    pfCon d (NormalC n [t1,t2])
 
+dataDeclToType :: (Name, [Name]) -> Type
+dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
+
+pfField :: (Name, [Name]) -> Type -> Q Type
+pfField d t | t == dataDeclToType d = conT ''I
+pfField d t                         = conT ''K `appT` return t
+
+pfField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
+pfField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
+pfField' (dt, vs) ns (f, _, t)                  = conT ''S `appT` conT (genName [dt, ns, f]) `appT` (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 (DataD _ dt vs cs _) ->
+                  zipWith (fromCon wrapE ns (dt, vs) (length cs)) [0..] cs
+                TyConI (NewtypeD _ dt vs c _) ->
+                  [fromCon wrapE ns (dt, vs) 1 0 c]
                 TyConI (TySynD t _ _) ->
                   [clause [varP (field 0)] (normalB (wrapE $ conE 'K `appE` varE (field 0))) []]
                 _ -> error "unknown construct"
@@ -174,56 +254,81 @@
       -- 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 (DataD _ dt vs cs _) ->
+                  zipWith (toCon wrapP ns (dt, vs) (length cs)) [0..] cs
+                TyConI (NewtypeD _ dt vs c _) ->
+                  [toCon wrapP ns (dt, vs) 1 0 c]
                 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 []) =
+fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+fromCon wrap ns (dt, vs) 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) =
+fromCon wrap ns (dt, vs) 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))) []
+      (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField (dt, vs)) [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])
+fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
+    clause
+      [conP cn []]
+      (normalB $ wrap $ lrE m i $ conE 'C `appE` (conE 'U)) []
+fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+    clause
+      [conP cn (map (varP . field) [0..length fs - 1])]
+      (normalB $ wrap $ lrE m i $ conE 'C `appE` foldr1 prod (zipWith (fromField' (dt, vs)) [0..] fs)) []
+  where
+    prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+  fromCon wrap ns (dt, vs) 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 []) =
+fromField :: (Name, [Name]) -> Int -> Type -> Q Exp
+fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
+fromField (dt, vs) nr t                                = conE 'K `appE` varE (field nr)
+
+fromField' :: (Name, [Name]) -> Int -> (Name, Strict, Type) -> Q Exp
+fromField' (dt, vs) nr (_, _, t) | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)
+fromField' (dt, vs) nr (_, _, t)                                = conE 'S `appE` (conE 'K `appE` varE (field nr))
+
+toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause
+toCon wrap ns (dt, vs) 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) =
+toCon wrap ns (dt, vs) 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))]]
+      [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField (dt, vs)) [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])
+toCon wrap ns (dt, vs) m i r@(RecC cn []) =
+    clause
+      [wrap $ lrP m i $ conP 'C [conP 'U []]]
+      (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+    clause
+      [wrap $ lrP m i $ conP 'C [foldr1 prod (zipWith (toField' (dt, vs)) [0..] fs)]]
+      (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) []
+  where
+    prod x y = conP '(:*:) [x,y]
+toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) =
+  toCon wrap ns (dt, vs) 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, [Name]) -> Int -> Type -> Q Pat
+toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
+toField (dt, vs) nr t                                = conP 'K [varP (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)]
+toField' :: (Name, [Name]) -> Int -> (Name, Strict, Type) -> Q Pat
+toField' (dt, vs) nr (_, _, t) | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]
+toField' (dt, vs) nr (_, _, t)                                = conP 'S [conP 'K [varP (field nr)]]
 
 field :: Int -> Name
 field n = mkName $ "f" ++ show n