diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,28 +1,28 @@
-Copyright (c) 2010 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.
-
+Copyright (c) 2010 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
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,6 +1,6 @@
-module Main (main) where
-
-import Distribution.Simple
-
-main :: IO ()
-main = defaultMain
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/generic-deriving.cabal b/generic-deriving.cabal
--- a/generic-deriving.cabal
+++ b/generic-deriving.cabal
@@ -1,52 +1,53 @@
-name:                   generic-deriving
-version:                1.0.3
-synopsis:               Generic programming library for generalized deriving.
-description:
-
-  This package provides functionality for generalizing the deriving mechanism
-  in Haskell to arbitrary classes. It was first described in the paper:
-  .
-  *  /A generic deriving mechanism for Haskell/.
-     Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.
-     Haskell'10.
-  .
-  The current implementation integrates with the new GHC Generics. See
-  <http://www.haskell.org/haskellwiki/Generics> for more information.
-  Template Haskell code is provided for supporting GHC before version 7.2.
-
-category:               Generics
-copyright:              (c) 2011 Universiteit Utrecht
-license:                BSD3
-license-file:           LICENSE
-author:                 José Pedro Magalhães
-maintainer:             generics@haskell.org
-stability:              experimental
-build-type:             Custom
-cabal-version:          >= 1.6
-tested-with:            GHC == 7.0.3, GHC == 7.2.1
-extra-source-files:     examples/Examples.hs
-
-source-repository head
-  type: svn
-  location: https://subversion.cs.uu.nl/repos/project.dgp-haskell.libraries/generic-deriving/trunk/
-
-library
-  hs-source-dirs:       src
-  exposed-modules:      Generics.Deriving
-                        Generics.Deriving.Base
-                        Generics.Deriving.Instances
-
-                        Generics.Deriving.Enum
-                        Generics.Deriving.Eq
-                        Generics.Deriving.Functor
-                        Generics.Deriving.Show
-                        Generics.Deriving.Uniplate
-
-                        Generics.Deriving.TH
-                        
-  build-depends:        base < 4.6, template-haskell >=2.4 && <2.8
-  if impl(ghc > 7.0)
-    build-depends:      ghc-prim < 0.3
-
-  extensions:           CPP
-  ghc-options:          -Wall
+name:                   generic-deriving
+version:                1.2.1
+synopsis:               Generic programming library for generalised deriving.
+description:
+
+  This package provides functionality for generalising the deriving mechanism
+  in Haskell to arbitrary classes. It was first described in the paper:
+  .
+  *  /A generic deriving mechanism for Haskell/.
+     Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.
+     Haskell'10.
+  .
+  The current implementation integrates with the new GHC Generics. See
+  <http://www.haskell.org/haskellwiki/Generics> for more information.
+  Template Haskell code is provided for supporting GHC before version 7.2.
+
+category:               Generics
+copyright:              2011 Universiteit Utrecht, 2012 University of Oxford
+license:                BSD3
+license-file:           LICENSE
+author:                 José Pedro Magalhães
+maintainer:             generics@haskell.org
+stability:              experimental
+build-type:             Custom
+cabal-version:          >= 1.6
+tested-with:            GHC == 7.0.3, GHC == 7.2.1, GHC == 7.4.1
+extra-source-files:     examples/Examples.hs
+
+source-repository head
+  type: git
+  location: https://github.com/dreixel/generic-deriving
+
+library
+  hs-source-dirs:       src
+  exposed-modules:      Generics.Deriving
+                        Generics.Deriving.Base
+                        Generics.Deriving.Instances
+
+                        Generics.Deriving.ConNames
+                        Generics.Deriving.Enum
+                        Generics.Deriving.Eq
+                        Generics.Deriving.Functor
+                        Generics.Deriving.Show
+                        Generics.Deriving.Uniplate
+
+                        Generics.Deriving.TH
+                        
+  build-depends:        base < 4.6, template-haskell >=2.4 && <2.8
+  if impl(ghc > 7.0)
+    build-depends:      ghc-prim < 0.3
+
+  extensions:           CPP
+  ghc-options:          -Wall
diff --git a/src/Generics/Deriving.hs b/src/Generics/Deriving.hs
--- a/src/Generics/Deriving.hs
+++ b/src/Generics/Deriving.hs
@@ -2,6 +2,7 @@
 module Generics.Deriving (
 
     module Generics.Deriving.Base,
+    module Generics.Deriving.ConNames,
     module Generics.Deriving.Enum,
     module Generics.Deriving.Eq,
     module Generics.Deriving.Functor,
@@ -11,6 +12,7 @@
   ) where
 
 import Generics.Deriving.Base
+import Generics.Deriving.ConNames
 import Generics.Deriving.Enum
 import Generics.Deriving.Eq
 import Generics.Deriving.Functor
diff --git a/src/Generics/Deriving/ConNames.hs b/src/Generics/Deriving/ConNames.hs
new file mode 100644
--- /dev/null
+++ b/src/Generics/Deriving/ConNames.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE FlexibleContexts      #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Deriving.ConNames
+-- Copyright   :  (c) 2012 University of Oxford
+-- License     :  BSD3
+--
+-- Maintainer  :  generics@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Summary: Return the name of all the constructors of a type.
+--
+-----------------------------------------------------------------------------
+
+module Generics.Deriving.ConNames (
+
+    -- * Functionality for retrieving the names of all the possible contructors
+    --   of a type
+    ConNames(..), conNames
+
+  ) where
+
+import Generics.Deriving.Base
+
+
+class ConNames f where 
+    gconNames :: f a -> [String]
+
+instance (ConNames f, ConNames g) => ConNames (f :+: g) where
+    gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++
+                                   gconNames (undefined :: g a)
+
+instance (ConNames f) => ConNames (D1 c f) where
+    gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a)
+    
+instance (Constructor c) => ConNames (C1 c f) where
+    gconNames x = [conName x]
+
+-- We should never need any other instances.
+
+
+-- | Return the name of all the constructors of the type of the given term.
+conNames :: (Generic a, ConNames (Rep a)) => a -> [String]
+conNames x = gconNames (undefined `asTypeOf` (from x))
diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs
--- a/src/Generics/Deriving/TH.hs
+++ b/src/Generics/Deriving/TH.hs
@@ -1,411 +1,411 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
-{-# OPTIONS_GHC -w           #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  Generics.Deriving.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 generic deriving
--- library. For now, it generates only the 'Generic' instance.
--- Empty datatypes are not yet supported.
------------------------------------------------------------------------------
-
--- Adapted from Generics.Regular.TH
-module Generics.Deriving.TH (
-      
-      deriveMeta
-    , deriveData
-    , deriveConstructors
-    , deriveSelectors
-
-#if __GLASGOW_HASKELL__ < 701
-    , deriveAll
-    , deriveRepresentable0
-    , deriveRep0
-    , simplInstance
-#endif
-  ) where
-
-import Generics.Deriving.Base
-
-import Language.Haskell.TH hiding (Fixity())
-import Language.Haskell.TH.Syntax (Lift(..))
-
-import Data.List (intercalate)
-import Control.Monad
-
--- | Given the names of a generic class, a type to instantiate, a function in
--- the class and the default implementation, generates the code for a basic
--- generic instance.
-simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
-simplInstance cl ty fn df = do
-  i <- reify (genRepName 0 ty)
-  x <- newName "x"
-  let typ = ForallT [PlainTV x] [] 
-        ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty)) 
-          (typeVariables i)) `AppT` (VarT x))
-  fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)
-    [funD fn [clause [] (normalB (varE df `appE` 
-      (sigE (global 'undefined) (return typ)))) []]]
-
-
--- | Given the type and the name (as string) for the type to derive,
--- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
--- instances, and the 'Representable0' instance.
-deriveAll :: Name -> Q [Dec]
-deriveAll n =
-  do a <- deriveMeta n
-     b <- deriveRepresentable0 n
-     return (a ++ b)
-
--- | Given the type and the name (as string) for the type to derive,
--- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
--- instances.
-deriveMeta :: Name -> Q [Dec]
-deriveMeta n =
-  do a <- deriveData n
-     b <- deriveConstructors n
-     c <- deriveSelectors n
-     return (a ++ b ++ c)
-
--- | Given a datatype name, derive a datatype and instance of class 'Datatype'.
-deriveData :: Name -> Q [Dec]
-deriveData = dataInstance
-
--- | 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 Representable0 type
--- synonym to derive, generate the 'Representable0' instance.
-deriveRepresentable0 :: Name -> Q [Dec]
-deriveRepresentable0 n = do
-    rep0 <- deriveRep0 n
-    inst <- deriveInst n
-    return $ rep0 ++ inst
-
--- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'
--- is used.
-deriveRep0 :: Name -> Q [Dec]
-deriveRep0 n = do
-  i <- reify n
-  fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n)
-
-deriveInst :: Name -> Q [Dec]
-deriveInst t = do
-  i <- reify t
-  let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) 
-                (typeVariables i)
-  let tyIns = TySynInstD ''Rep [typ t] (typ (genRepName 0 t))
-  fcs <- mkFrom t 1 0 t
-  tcs <- mkTo   t 1 0 t
-  liftM (:[]) $
-    instanceD (cxt []) (conT ''Generic `appT` return (typ t))
-                         [return tyIns, funD 'from fcs, funD 'to tcs]
-
-
-dataInstance :: Name -> Q [Dec]
-dataInstance n = do
-  i <- reify n
-  case i of
-    TyConI (DataD    _ n _ _ _) -> mkInstance n
-    TyConI (NewtypeD _ n _ _ _) -> mkInstance n
-    _ -> return []
-  where
-    mkInstance n = do
-      ds <- mkDataData n
-      is <- mkDataInstance n
-      return $ [ds,is]
-
-constrInstance :: Name -> Q [Dec]
-constrInstance 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 (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 -> [TyVarBndr]
-typeVariables (TyConI (DataD    _ _ tv _ _)) = tv
-typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
-typeVariables _                           = []
-
-tyVarBndrToName :: TyVarBndr -> Name
-tyVarBndrToName (PlainTV  name)   = name
-tyVarBndrToName (KindedTV name _) = name
-
-stripRecordNames :: Con -> Con
-stripRecordNames (RecC n f) =
-  NormalC n (map (\(_, s, t) -> (s, t)) f)
-stripRecordNames c = c
-
-genName :: [Name] -> Name
-genName = mkName . (++"_") . intercalate "_" . map nameBase
-
-genRepName :: Int -> Name -> Name
-genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase
-
-mkDataData :: Name -> Q Dec
-mkDataData n = dataD (cxt []) (genName [n]) [] [] []
-
-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 []
-
-
-mkDataInstance :: Name -> Q Dec
-mkDataInstance n =
-  instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n]))
-    [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []]
-    ,funD 'moduleName   [clause [wildP] (normalB (stringE name)) []]]
-  where
-    name = maybe (error "Cannot fetch module name!") id (nameModule n)
-
-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
-
-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 $ 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
-    convertDirection InfixL = LeftAssociative
-    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 []
-
-rep0Type :: Name -> Q Type
-rep0Type n =
-    do
-      -- runIO $ putStrLn $ "processing " ++ show n
-      i <- reify n
-      let b = case i of
-                TyConI (DataD _ dt vs cs _) ->
-                  (conT ''D1) `appT` (conT $ genName [dt]) `appT` 
-                    (foldr1' sum (conT ''V1) 
-                      (map (rep0Con (dt, map tyVarBndrToName vs)) cs))
-                TyConI (NewtypeD _ dt vs c _) ->
-                  (conT ''D1) `appT` (conT $ genName [dt]) `appT`
-                    (rep0Con (dt, map tyVarBndrToName vs) c)
-                TyConI (TySynD t _ _) -> error "type synonym?" 
-                _ -> 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
-
-
-rep0Con :: (Name, [Name]) -> Con -> Q Type
-rep0Con (dt, vs) (NormalC n []) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
-     (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1)
-rep0Con (dt, vs) (NormalC n fs) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
-     (foldr1 prod (map (repField (dt, vs) . snd) fs)) where
-    prod :: Q Type -> Q Type -> Q Type
-    prod a b = conT ''(:*:) `appT` a `appT` b
-rep0Con (dt, vs) r@(RecC n []) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1
-rep0Con (dt, vs) r@(RecC n fs) =
-    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
-      (foldr1 prod (map (repField' (dt, vs) n) fs)) where
-    prod :: Q Type -> Q Type -> Q Type
-    prod a b = conT ''(:*:) `appT` a `appT` b
-
-rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2])
-
---dataDeclToType :: (Name, [Name]) -> Type
---dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
-
-repField :: (Name, [Name]) -> Type -> Q Type
---repField d t | t == dataDeclToType d = conT ''I
-repField d t = conT ''S1 `appT` conT ''NoSelector `appT`
-                 (conT ''Rec0 `appT` return t)
-
-repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
---repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
-repField' (dt, vs) ns (f, _, t) = conT ''S1 `appT` conT (genName [dt, ns, f]) 
-                                    `appT` (conT ''Rec0 `appT` return t)
--- Note: we should generate Par0 too, at some point
-
-
-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 b = case i of
-                TyConI (DataD _ dt vs cs _) ->
-                  zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
-                    (length cs)) [0..] cs
-                TyConI (NewtypeD _ dt vs c _) ->
-                  [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
-                TyConI (TySynD t _ _) -> error "type synonym?" 
-                  -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `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 b = case i of
-                TyConI (DataD _ dt vs cs _) ->
-                  zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
-                    (length cs)) [0..] cs
-                TyConI (NewtypeD _ dt vs c _) ->
-                  [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
-                TyConI (TySynD t _ _) -> error "type synonym?" 
-                  -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
-                _ -> error "unknown construct" 
-      return b
-
-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 $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $ 
-      conE 'M1 `appE` (conE 'U1)) []
-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 $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` 
-      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
-  where prod x y = conE '(:*:) `appE` x `appE` y
-fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
-  clause
-    [conP cn []]
-    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) []
-fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
-  clause
-    [conP cn (map (varP . field) [0..length fs - 1])]
-    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` 
-      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd 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])
-
-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 'M1 `appE` (conE 'K1 `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 $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]]
-      (normalB $ conE cn) []
-toCon wrap ns (dt, vs) m i (NormalC cn fs) =
-    -- runIO (putStrLn ("constructor " ++ show ix)) >>
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1
-        [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 (dt, vs) m i r@(RecC cn []) =
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]]
-      (normalB $ conE cn) []
-toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
-    clause
-      [wrap $ conP 'M1 [lrP m i $ conP 'M1
-        [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd 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])
-
-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 'M1 [conP 'K1 [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 'L1 [p]
-lrP m i p = conP 'R1 [lrP (m-1) (i-1) p]
-
-lrE :: Int -> Int -> (Q Exp -> Q Exp)
-lrE 1 0 e = e
-lrE m 0 e = conE 'L1 `appE` e
-lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) e
-
-trd (_,_,c) = c
-
--- | Variant of foldr1 which returns a special element for empty lists
-foldr1' f x [] = x
-foldr1' _ _ [x] = x
-foldr1' f x (h:t) = f h (foldr1' f x t)
+{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# OPTIONS_GHC -w           #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Generics.Deriving.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 generic deriving
+-- library. For now, it generates only the 'Generic' instance.
+-- Empty datatypes are not yet supported.
+-----------------------------------------------------------------------------
+
+-- Adapted from Generics.Regular.TH
+module Generics.Deriving.TH (
+      
+      deriveMeta
+    , deriveData
+    , deriveConstructors
+    , deriveSelectors
+
+#if __GLASGOW_HASKELL__ < 701
+    , deriveAll
+    , deriveRepresentable0
+    , deriveRep0
+    , simplInstance
+#endif
+  ) where
+
+import Generics.Deriving.Base
+
+import Language.Haskell.TH hiding (Fixity())
+import Language.Haskell.TH.Syntax (Lift(..))
+
+import Data.List (intercalate)
+import Control.Monad
+
+-- | Given the names of a generic class, a type to instantiate, a function in
+-- the class and the default implementation, generates the code for a basic
+-- generic instance.
+simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]
+simplInstance cl ty fn df = do
+  i <- reify (genRepName 0 ty)
+  x <- newName "x"
+  let typ = ForallT [PlainTV x] [] 
+        ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty)) 
+          (typeVariables i)) `AppT` (VarT x))
+  fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)
+    [funD fn [clause [] (normalB (varE df `appE` 
+      (sigE (global 'undefined) (return typ)))) []]]
+
+
+-- | Given the type and the name (as string) for the type to derive,
+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'
+-- instances, and the 'Representable0' instance.
+deriveAll :: Name -> Q [Dec]
+deriveAll n =
+  do a <- deriveMeta n
+     b <- deriveRepresentable0 n
+     return (a ++ b)
+
+-- | Given the type and the name (as string) for the type to derive,
+-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
+-- instances.
+deriveMeta :: Name -> Q [Dec]
+deriveMeta n =
+  do a <- deriveData n
+     b <- deriveConstructors n
+     c <- deriveSelectors n
+     return (a ++ b ++ c)
+
+-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.
+deriveData :: Name -> Q [Dec]
+deriveData = dataInstance
+
+-- | 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 Representable0 type
+-- synonym to derive, generate the 'Representable0' instance.
+deriveRepresentable0 :: Name -> Q [Dec]
+deriveRepresentable0 n = do
+    rep0 <- deriveRep0 n
+    inst <- deriveInst n
+    return $ rep0 ++ inst
+
+-- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'
+-- is used.
+deriveRep0 :: Name -> Q [Dec]
+deriveRep0 n = do
+  i <- reify n
+  fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n)
+
+deriveInst :: Name -> Q [Dec]
+deriveInst t = do
+  i <- reify t
+  let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) 
+                (typeVariables i)
+  let tyIns = TySynInstD ''Rep [typ t] (typ (genRepName 0 t))
+  fcs <- mkFrom t 1 0 t
+  tcs <- mkTo   t 1 0 t
+  liftM (:[]) $
+    instanceD (cxt []) (conT ''Generic `appT` return (typ t))
+                         [return tyIns, funD 'from fcs, funD 'to tcs]
+
+
+dataInstance :: Name -> Q [Dec]
+dataInstance n = do
+  i <- reify n
+  case i of
+    TyConI (DataD    _ n _ _ _) -> mkInstance n
+    TyConI (NewtypeD _ n _ _ _) -> mkInstance n
+    _ -> return []
+  where
+    mkInstance n = do
+      ds <- mkDataData n
+      is <- mkDataInstance n
+      return $ [ds,is]
+
+constrInstance :: Name -> Q [Dec]
+constrInstance 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 (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 -> [TyVarBndr]
+typeVariables (TyConI (DataD    _ _ tv _ _)) = tv
+typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv
+typeVariables _                           = []
+
+tyVarBndrToName :: TyVarBndr -> Name
+tyVarBndrToName (PlainTV  name)   = name
+tyVarBndrToName (KindedTV name _) = name
+
+stripRecordNames :: Con -> Con
+stripRecordNames (RecC n f) =
+  NormalC n (map (\(_, s, t) -> (s, t)) f)
+stripRecordNames c = c
+
+genName :: [Name] -> Name
+genName = mkName . (++"_") . intercalate "_" . map nameBase
+
+genRepName :: Int -> Name -> Name
+genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase
+
+mkDataData :: Name -> Q Dec
+mkDataData n = dataD (cxt []) (genName [n]) [] [] []
+
+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 []
+
+
+mkDataInstance :: Name -> Q Dec
+mkDataInstance n =
+  instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n]))
+    [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []]
+    ,funD 'moduleName   [clause [wildP] (normalB (stringE name)) []]]
+  where
+    name = maybe (error "Cannot fetch module name!") id (nameModule n)
+
+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
+
+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 $ 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
+    convertDirection InfixL = LeftAssociative
+    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 []
+
+rep0Type :: Name -> Q Type
+rep0Type n =
+    do
+      -- runIO $ putStrLn $ "processing " ++ show n
+      i <- reify n
+      let b = case i of
+                TyConI (DataD _ dt vs cs _) ->
+                  (conT ''D1) `appT` (conT $ genName [dt]) `appT` 
+                    (foldr1' sum (conT ''V1) 
+                      (map (rep0Con (dt, map tyVarBndrToName vs)) cs))
+                TyConI (NewtypeD _ dt vs c _) ->
+                  (conT ''D1) `appT` (conT $ genName [dt]) `appT`
+                    (rep0Con (dt, map tyVarBndrToName vs) c)
+                TyConI (TySynD t _ _) -> error "type synonym?" 
+                _ -> 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
+
+
+rep0Con :: (Name, [Name]) -> Con -> Q Type
+rep0Con (dt, vs) (NormalC n []) =
+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
+     (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1)
+rep0Con (dt, vs) (NormalC n fs) =
+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
+     (foldr1 prod (map (repField (dt, vs) . snd) fs)) where
+    prod :: Q Type -> Q Type -> Q Type
+    prod a b = conT ''(:*:) `appT` a `appT` b
+rep0Con (dt, vs) r@(RecC n []) =
+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1
+rep0Con (dt, vs) r@(RecC n fs) =
+    conT ''C1 `appT` (conT $ genName [dt, n]) `appT` 
+      (foldr1 prod (map (repField' (dt, vs) n) fs)) where
+    prod :: Q Type -> Q Type -> Q Type
+    prod a b = conT ''(:*:) `appT` a `appT` b
+
+rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2])
+
+--dataDeclToType :: (Name, [Name]) -> Type
+--dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs
+
+repField :: (Name, [Name]) -> Type -> Q Type
+--repField d t | t == dataDeclToType d = conT ''I
+repField d t = conT ''S1 `appT` conT ''NoSelector `appT`
+                 (conT ''Rec0 `appT` return t)
+
+repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type
+--repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I
+repField' (dt, vs) ns (f, _, t) = conT ''S1 `appT` conT (genName [dt, ns, f]) 
+                                    `appT` (conT ''Rec0 `appT` return t)
+-- Note: we should generate Par0 too, at some point
+
+
+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 b = case i of
+                TyConI (DataD _ dt vs cs _) ->
+                  zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs)
+                    (length cs)) [0..] cs
+                TyConI (NewtypeD _ dt vs c _) ->
+                  [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c]
+                TyConI (TySynD t _ _) -> error "type synonym?" 
+                  -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `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 b = case i of
+                TyConI (DataD _ dt vs cs _) ->
+                  zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs)
+                    (length cs)) [0..] cs
+                TyConI (NewtypeD _ dt vs c _) ->
+                  [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c]
+                TyConI (TySynD t _ _) -> error "type synonym?" 
+                  -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []]
+                _ -> error "unknown construct" 
+      return b
+
+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 $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $ 
+      conE 'M1 `appE` (conE 'U1)) []
+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 $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` 
+      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) []
+  where prod x y = conE '(:*:) `appE` x `appE` y
+fromCon wrap ns (dt, vs) m i r@(RecC cn []) =
+  clause
+    [conP cn []]
+    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) []
+fromCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+  clause
+    [conP cn (map (varP . field) [0..length fs - 1])]
+    (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` 
+      foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd 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])
+
+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 'M1 `appE` (conE 'K1 `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 $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]]
+      (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i (NormalC cn fs) =
+    -- runIO (putStrLn ("constructor " ++ show ix)) >>
+    clause
+      [wrap $ conP 'M1 [lrP m i $ conP 'M1
+        [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 (dt, vs) m i r@(RecC cn []) =
+    clause
+      [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]]
+      (normalB $ conE cn) []
+toCon wrap ns (dt, vs) m i r@(RecC cn fs) =
+    clause
+      [wrap $ conP 'M1 [lrP m i $ conP 'M1
+        [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd 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])
+
+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 'M1 [conP 'K1 [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 'L1 [p]
+lrP m i p = conP 'R1 [lrP (m-1) (i-1) p]
+
+lrE :: Int -> Int -> (Q Exp -> Q Exp)
+lrE 1 0 e = e
+lrE m 0 e = conE 'L1 `appE` e
+lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) e
+
+trd (_,_,c) = c
+
+-- | Variant of foldr1 which returns a special element for empty lists
+foldr1' f x [] = x
+foldr1' _ _ [x] = x
+foldr1' f x (h:t) = f h (foldr1' f x t)