generic-deriving 1.0.3 → 1.2.1

raw patch · 6 files changed

+549/−497 lines, 6 filesdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

+ Generics.Deriving.ConNames: class ConNames f

+ Generics.Deriving.ConNames: conNames :: (Generic a, ConNames (Rep a)) => a -> [String]

+ Generics.Deriving.ConNames: gconNames :: ConNames f => f a -> [String]

+ Generics.Deriving.ConNames: instance (ConNames f, ConNames g) => ConNames (f :+: g)

+ Generics.Deriving.ConNames: instance ConNames f => ConNames (D1 c f)

+ Generics.Deriving.ConNames: instance Constructor c => ConNames (C1 c f)

- Generics.Deriving.Base: class Generic a where { type family Rep a :: * -> *; }

+ Generics.Deriving.Base: class Generic a where type family Rep a :: * -> *

- Generics.Deriving.Base: class Generic1 f :: (* -> *) where { type family Rep1 f :: (* -> *) :: * -> *; }

+ Generics.Deriving.Base: class Generic1 (f :: * -> *) where type family Rep1 (f :: * -> *) :: * -> *

- Generics.Deriving.Base: data (:*:) f :: (* -> *) g :: (* -> *) p :: (* -> *) -> (* -> *) -> * -> *

+ Generics.Deriving.Base: data (:*:) (f :: * -> *) (g :: * -> *) p :: (* -> *) -> (* -> *) -> * -> *

- Generics.Deriving.Base: newtype (:.:) f :: (* -> *) g :: (* -> *) p :: (* -> *) -> (* -> *) -> * -> *

+ Generics.Deriving.Base: newtype (:.:) (f :: * -> *) (g :: * -> *) p :: (* -> *) -> (* -> *) -> * -> *

- Generics.Deriving.Base: newtype M1 i c f :: (* -> *) p :: * -> * -> (* -> *) -> * -> *

+ Generics.Deriving.Base: newtype M1 i c (f :: * -> *) p :: * -> * -> (* -> *) -> * -> *

- Generics.Deriving.Base: newtype Rec1 f :: (* -> *) p :: (* -> *) -> * -> *

+ Generics.Deriving.Base: newtype Rec1 (f :: * -> *) p :: (* -> *) -> * -> *

- Generics.Deriving.Enum: class GEnum a

+ Generics.Deriving.Enum: class GEnum a where genum = genumDefault

- Generics.Deriving.Enum: class Ord a => GIx a

+ Generics.Deriving.Enum: class Ord a => GIx a where range = rangeDefault index = indexDefault inRange = inRangeDefault

- Generics.Deriving.Eq: class GEq a

+ Generics.Deriving.Eq: class GEq a where geq x y = geq' (from x) (from y)

- Generics.Deriving.Functor: class GFunctor f

+ Generics.Deriving.Functor: class GFunctor f where gmap = gmapdefault

- Generics.Deriving.Show: class GShow a

+ Generics.Deriving.Show: class GShow a where gshows = gshowsPrec 0 gshow x = gshows x "" gshowsPrec = gshowsPrecdefault

- Generics.Deriving.Uniplate: class Uniplate a

+ Generics.Deriving.Uniplate: class Uniplate a where children = childrendefault

Files

LICENSE +28/−28
Setup.hs +6/−6
generic-deriving.cabal +53/−52
src/Generics/Deriving.hs +2/−0
src/Generics/Deriving/ConNames.hs +49/−0
src/Generics/Deriving/TH.hs +411/−411

LICENSE view

@@ -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.
+

Setup.hs view

@@ -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

generic-deriving.cabal view

@@ -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

src/Generics/Deriving.hs view

@@ -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

+ src/Generics/Deriving/ConNames.hs view

@@ -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))

src/Generics/Deriving/TH.hs view

@@ -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)