diff --git a/CHANGES.txt b/CHANGES.txt
--- a/CHANGES.txt
+++ b/CHANGES.txt
@@ -1,5 +1,9 @@
 Changelog for Derive
 
+2.5.24
+    #14, update to GHC 8.0.1
+    #15, move all the source files under src to speed up building
+    Delete the FixedPpr module, was unused
 2.5.23
     Require haskell-src-exts-1.17
 2.5.22
diff --git a/Data/Derive/All.hs b/Data/Derive/All.hs
deleted file mode 100644
--- a/Data/Derive/All.hs
+++ /dev/null
@@ -1,45 +0,0 @@
--- | This module provides convenience re-exports of all the standard
--- Data.Derive derivations.
-module Data.Derive.All (Derivation, derivations, module D) where
-
-import Data.Derive.Internal.Derivation
-
--- GENERATED START
-import Data.Derive.Arbitrary           as D
-import Data.Derive.ArbitraryOld        as D
-import Data.Derive.Arities             as D
-import Data.Derive.Binary              as D
-import Data.Derive.BinaryDefer         as D
-import Data.Derive.Bounded             as D
-import Data.Derive.Data                as D
-import Data.Derive.DataAbstract        as D
-import Data.Derive.Default             as D
-import Data.Derive.Enum                as D
-import Data.Derive.EnumCyclic          as D
-import Data.Derive.Eq                  as D
-import Data.Derive.Fold                as D
-import Data.Derive.Foldable            as D
-import Data.Derive.From                as D
-import Data.Derive.Functor             as D
-import Data.Derive.Has                 as D
-import Data.Derive.Is                  as D
-import Data.Derive.JSON                as D
-import Data.Derive.LazySet             as D
-import Data.Derive.Lens                as D
-import Data.Derive.Monoid              as D
-import Data.Derive.NFData              as D
-import Data.Derive.Ord                 as D
-import Data.Derive.Read                as D
-import Data.Derive.Ref                 as D
-import Data.Derive.Serial              as D
-import Data.Derive.Serialize           as D
-import Data.Derive.Set                 as D
-import Data.Derive.Show                as D
-import Data.Derive.Traversable         as D
-import Data.Derive.Typeable            as D
-import Data.Derive.UniplateDirect      as D
-import Data.Derive.UniplateTypeable    as D
-import Data.Derive.Update              as D
-derivations :: [Derivation]
-derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSerialize,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate]
--- GENERATED STOP
diff --git a/Data/Derive/Arbitrary.hs b/Data/Derive/Arbitrary.hs
deleted file mode 100644
--- a/Data/Derive/Arbitrary.hs
+++ /dev/null
@@ -1,83 +0,0 @@
-module Data.Derive.Arbitrary(makeArbitrary) where
-{-
-import "QuickCheck" Test.QuickCheck
-
-example :: Custom
-
-instance Arbitrary (Sample a) where
-    arbitrary = do
-        x <- choose (0::Int,length [First{},Second{},Third{}] - 1)
-        case x of
-            0 -> do return (First)
-            1 -> do x1 <- arbitrary
-                    x2 <- arbitrary
-                    return (Second x1 x2)
-            2 -> do x1 <- arbitrary
-                    return (Third x1)
-            _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
-
-test :: State
-instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where
-    arbitrary = do x1 <- arbitrary
-                   return (StateT x1)
--}
-
-import Data.Derive.DSL.HSE
-import Data.List
-import Data.Generics.Uniplate.DataOnly
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeArbitrary :: Derivation
-makeArbitrary = derivationCustomDSL "Arbitrary" custom $
-    List [Instance [] "Arbitrary" (List [App "InsDecl" (List [App
-    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [List [
-    App "Generator" (List [App "PVar" (List [App "Ident" (List [String
-    "x"])]),App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "choose"])])]),App "Tuple" (List [App
-    "Boxed" (List []),List [App "ExpTypeSig" (List [App "Lit" (List [
-    App "Int" (List [Int 0])]),App "TyCon" (List [App "UnQual" (List [
-    App "Ident" (List [String "Int"])])])]),App "InfixApp" (List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "length"])])]),App "List" (List [MapCtor (App
-    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
-    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List
-    [Int 1])])])]])])]),App "Qualifier" (List [App "Case" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])])
-    ]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [App
-    "Signless" (List []),App "Int" (List [CtorIndex])]),App
-    "UnGuardedRhs" (List [App "Do" (List [Concat (List [MapField (App
-    "Generator" (List [App "PVar" (List [App "Ident" (List [Concat (
-    List [String "x",ShowInt FieldIndex])])]),App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "arbitrary"])])])])),
-    List [App "Qualifier" (List [App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "return"])])]),App
-    "Paren" (List [Application (Concat (List [List [App "Con" (List [
-    App "UnQual" (List [App "Ident" (List [CtorName])])])],MapField (
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
-    List [String "x",ShowInt FieldIndex])])])]))]))])])])]])])]),App
-    "Nothing" (List [])])),List [App "Alt" (List [App "PWildCard" (
-    List []),App "UnGuardedRhs" (List [App "App" (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "error"])])]),
-    App "Lit" (List [App "String" (List [String
-    "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "Nothing"
-    (List [])])]])])])]])]),App "Nothing" (List [])])])])]
--- GENERATED STOP
-
-custom = customContext context
-
--- Fix the context
--- C a b => Arbitrary a, Arbitrary b
--- a -> b => CoArbitrary a, Arbitrary b
-context :: FullDataDecl -> Context -> Context
-context (_,d) _ = nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d
-    where
-        f b (TyVar x) = [ClassA (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar x]]
-        f b (TyFun x y) = f (not b) x ++ f b y
-        f b x = concatMap (f b) (children x)
-
diff --git a/Data/Derive/ArbitraryOld.hs b/Data/Derive/ArbitraryOld.hs
deleted file mode 100644
--- a/Data/Derive/ArbitraryOld.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-module Data.Derive.ArbitraryOld where
-{-
-import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)
-
-example :: Sample
-
-instance Arbitrary a => Arbitrary (Sample a) where
-    arbitrary = do
-        x <- choose (0,length [First{},Second{},Third{}]-1)
-        case x of
-            0 -> do return (First)
-            1 -> do x1 <- arbitrary
-                    x2 <- arbitrary
-                    return (Second x1 x2)
-            2 -> do x1 <- arbitrary
-                    return (Third x1)
-
-    coarbitrary (First) = variant 0
-    coarbitrary (Second x1 x2) = variant 1 . coarbitrary x1 . coarbitrary x2
-    coarbitrary (Third x1) = variant 2 . coarbitrary x1
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeArbitraryOld :: Derivation
-makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld
-
-dslArbitraryOld =
-    List [Instance ["Arbitrary"] "Arbitrary" (List [App "InsDecl" (
-    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
-    String "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [
-    List [App "Generator" (List [App "PVar" (List [App "Ident" (List [
-    String "x"])]),App "App" (List [App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "choose"])])]),App "Tuple" (List [
-    App "Boxed" (List []),List [App "Lit" (List [App "Int" (List [Int
-    0])]),App "InfixApp" (List [App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "length"])])]),App
-    "List" (List [MapCtor (App "RecConstr" (List [App "UnQual" (List [
-    App "Ident" (List [CtorName])]),List []]))])]),App "QVarOp" (List
-    [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App
-    "Lit" (List [App "Int" (List [Int 1])])])]])])]),App "Qualifier" (
-    List [App "Case" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "x"])])]),MapCtor (App "Alt" (List [App
-    "PLit" (List [App "Signless" (List []),App "Int" (List [CtorIndex]
-    )]),App "UnGuardedRhs" (List [App "Do" (List [Concat (List [
-    MapField (App "Generator" (List [App "PVar" (List [App "Ident" (
-    List [Concat (List [String "x",ShowInt FieldIndex])])]),App "Var"
-    (List [App "UnQual" (List [App "Ident" (List [String "arbitrary"])
-    ])])])),List [App "Qualifier" (List [App "App" (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "return"])])])
-    ,App "Paren" (List [Application (Concat (List [List [App "Con" (
-    List [App "UnQual" (List [App "Ident" (List [CtorName])])])],
-    MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    Concat (List [String "x",ShowInt FieldIndex])])])]))]))])])])]])])
-    ]),App "Nothing" (List [])]))])])]])]),App "Nothing" (List [])])])
-    ,App "InsDecl" (List [App "FunBind" (List [MapCtor (App "Match" (
-    List [App "Ident" (List [String "coarbitrary"]),List [App "PParen"
-    (List [App "PApp" (List [App "UnQual" (List [App "Ident" (List [
-    CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat
-    (List [String "x",ShowInt FieldIndex])])]))])])],App "Nothing" (
-    List []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [
-    Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
-    String "."])])]),Tail])) (Concat (List [List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "variant"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])]
-    ,MapField (App "App" (List [App "Var" (List [App "UnQual" (List [
-    App "Ident" (List [String "coarbitrary"])])]),App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [Concat (List [String "x",
-    ShowInt FieldIndex])])])])]))]))]),App "Nothing" (List [])]))])])]
-    )]
--- GENERATED STOP
diff --git a/Data/Derive/Arities.hs b/Data/Derive/Arities.hs
deleted file mode 100644
--- a/Data/Derive/Arities.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-module Data.Derive.Arities where
-{-
-import "derive" Data.Derive.Class.Arities
-
-example :: Sample
-
-instance Arities (Sample a) where
-    arities _ = [const 0 First{}, const 2 Second{}, const 1 Third{}]
-
-test :: []
-
-instance Arities [a] where
-    arities _ = [0,2]
-
-test :: Bool
-
-instance Arities Bool where
-    arities _ = [0,0]
-
-test :: Either
-
-instance Arities (Either a b) where
-    arities _ = [1,1]
--}
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeArities :: Derivation
-makeArities = derivationDSL "Arities" dslArities
-
-dslArities =
-    List [Instance [] "Arities" (List [App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "arities"]),List [App "PWildCard" (List [])],App "Nothing"
-    (List []),App "UnGuardedRhs" (List [App "List" (List [MapCtor (
-    Application (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "const"])])]),App "Lit" (List [App "Int" (
-    List [CtorArity])]),App "RecConstr" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])]),List []])]))])]),App "Nothing" (List [
-    ])])]])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Binary.hs b/Data/Derive/Binary.hs
deleted file mode 100644
--- a/Data/Derive/Binary.hs
+++ /dev/null
@@ -1,134 +0,0 @@
-module Data.Derive.Binary where
-{-
-import "binary" Data.Binary
-
-example :: Sample
-
-instance Binary alpha => Binary (Sample alpha) where
-    put x = case x of
-        First          -> do putTag 0
-        Second  x1 x2  -> do putTag 1 ; put x1 ; put x2
-        Third   x1     -> do putTag 2 ; put x1
-        where
-            useTag = length [First{}, Second{}, Third{}] > 1
-            putTag x = when useTag (putWord8 x)
-
-    get = do
-        i <- getTag
-        case i of
-            0 -> do return (First)
-            1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)
-            2 -> do x1 <- get ; return (Third x1)
-            _ -> error "Corrupted binary data for Sample"
-        where
-            useTag = length [First{}, Second{}, Third{}] > 1
-            getTag = if useTag then getWord8 else return 0
-
-
-test :: List
-
-instance Binary a => Binary (List a) where
-    put x = case x of
-        Nil -> putWord8 0
-        Cons x1 x2 -> do putWord8 1; put x1; put x2
-
-    get = do
-        i <- getWord8
-        case i of
-            0 -> return Nil
-            1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)
-            _ -> error "Corrupted binary data for List"
-
-test :: Assoced
-
-instance Binary typ => Binary (Assoced typ) where
-    put (Assoced x1 x2) = do put x1; put x2
-    get = do x1 <- get; x2 <- get; return (Assoced x1 x2)
-
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeBinary :: Derivation
-makeBinary = derivationDSL "Binary" dslBinary
-
-dslBinary =
-    List [Instance ["Binary"] "Binary" (List [App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "put"]),List [App "PVar" (List [App "Ident" (List [String
-    "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
-    "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List
-    [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
-    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])]))]),App "UnGuardedRhs" (List [App "Do" (List [
-    Concat (List [List [App "Qualifier" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])
-    ],MapField (App "Qualifier" (List [App "App" (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "put"])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
-    List [String "x",ShowInt FieldIndex])])])])])]))])])]),App
-    "Nothing" (List [])]))])]),App "Just" (List [App "BDecls" (List [
-    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
-    String "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List
-    [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "length"])])]),App "List" (List [MapCtor (App
-    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
-    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
-    [Int 1])])])]),App "Nothing" (List [])]),App "FunBind" (List [List
-    [App "Match" (List [App "Ident" (List [String "putTag"]),List [App
-    "PVar" (List [App "Ident" (List [String "x"])])],App "Nothing" (
-    List []),App "UnGuardedRhs" (List [Application (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "when"])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "useTag"])])]),App "Paren" (List [App "App" (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [Concat (List [String
-    "putWord",ShowInt (Int 8)])])])]),App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "x"])])])])])])]),App "Nothing" (
-    List [])])]])]])])])]])]),App "InsDecl" (List [App "PatBind" (List
-    [App "PVar" (List [App "Ident" (List [String "get"])]),App
-    "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List
-    [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "getTag"])])])
-    ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [
-    MapCtor (App "Alt" (List [App "PLit" (List [App "Signless" (List [
-    ]),App "Int" (List [CtorIndex])]),App "UnGuardedRhs" (List [App
-    "Do" (List [Concat (List [MapField (App "Generator" (List [App
-    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])]),App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "get"])])])])),List [App "Qualifier" (List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "return"])])]),App "Paren" (List [Application (Concat
-    (List [List [App "Con" (List [App "UnQual" (List [App "Ident" (
-    List [CtorName])])])],MapField (App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [])])),
-    List [App "Alt" (List [App "PWildCard" (List []),App
-    "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"
-    (List [App "String" (List [Concat (List [String
-    "Corrupted binary data for ",DataName])])])])]),App "Nothing" (
-    List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [List
-    [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "length"])])]),App "List" (List [MapCtor (App
-    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
-    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
-    [Int 1])])])]),App "Nothing" (List [])]),App "PatBind" (List [App
-    "PVar" (List [App "Ident" (List [String "getTag"])]),App
-    "UnGuardedRhs" (List [App "If" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "useTag"])])]),App "Var"
-    (List [App "UnQual" (List [App "Ident" (List [Concat (List [String
-    "getWord",ShowInt (Int 8)])])])]),App "App" (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [String "return"])])]),App
-    "Lit" (List [App "Int" (List [Int 0])])])])]),App "Nothing" (List
-    [])])]])])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/BinaryDefer.hs b/Data/Derive/BinaryDefer.hs
deleted file mode 100644
--- a/Data/Derive/BinaryDefer.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-module Data.Derive.BinaryDefer where
-{-
-import "binarydefer" Data.Binary.Defer
-
-example :: Sample
-
-instance BinaryDefer a => BinaryDefer (Sample a) where
-    bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) <<! o else unit First
-                      ,\ ~(o@(Second x1 x2)) -> if null [const () x1, const () x2] then unit (Second x1 x2) <<! o else unit Second << x1 << x2
-                      ,\ ~(o@(Third x1)) -> if null [const () x1] then unit (Third x1) <<! o else unit Third << x1
-                      ]
-
-test :: FailList
-
-instance (BinaryDefer e, BinaryDefer a) => BinaryDefer (FailList e a) where
-    bothDefer = defer [\ ~(o@Zoro) -> unit Zoro <<! o
-                      ,\ ~(Fial x1) -> unit Fial << x1
-                      ,\ ~(Const x1 x2) -> unit Const << x1 << x2
-                      ]
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeBinaryDefer :: Derivation
-makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer
-
-dslBinaryDefer =
-    List [Instance ["BinaryDefer"] "BinaryDefer" (List [App "InsDecl"
-    (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
-    String "bothDefer"])]),App "UnGuardedRhs" (List [App "App" (List [
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "defer"])])]),App "List" (List [MapCtor (App "Lambda" (List [List
-    [App "PIrrPat" (List [App "PParen" (List [App "PAsPat" (List [App
-    "Ident" (List [String "o"]),App "PParen" (List [App "PApp" (List [
-    App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
-    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])]))])])])])])],App "If" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "null"]
-    )])]),App "List" (List [MapField (Application (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "const"])])]),
-    App "Con" (List [App "Special" (List [App "UnitCon" (List [])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
-    List [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp"
-    (List [App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "unit"])])]),App "Paren" (List [Application
-    (Concat (List [List [App "Con" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])])])],MapField (App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [Concat (List [String "x",
-    ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (List [App
-    "UnQual" (List [App "Symbol" (List [String "<<!"])])]),App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "o"])])])]),
-    Fold (App "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual"
-    (List [App "Symbol" (List [String "<<"])])]),Head])) (Concat (List
-    [Reverse (MapField (App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])])])
-    )),List [App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "unit"])])]),App "Con" (List [App "UnQual" (
-    List [App "Ident" (List [CtorName])])])])]]))])]))])])]),App
-    "Nothing" (List [])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Bounded.hs b/Data/Derive/Bounded.hs
deleted file mode 100644
--- a/Data/Derive/Bounded.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-module Data.Derive.Bounded where
-{-
-import Prelude
-
-example :: Sample
-
-instance Bounded a => Bounded (Sample a) where
-    minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]
-    maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First]
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeBounded :: Derivation
-makeBounded = derivationDSL "Bounded" dslBounded
-
-dslBounded =
-    List [Instance ["Bounded"] "Bounded" (List [App "InsDecl" (List [
-    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "minBound"])]),App "UnGuardedRhs" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "head"]
-    )])]),App "List" (List [MapCtor (Application (Concat (List [List [
-    App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])
-    ])])],MapField (App "Paren" (List [Application (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "const"])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "minBound"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])]
-    )]))])))])])]),App "Nothing" (List [])])]),App "InsDecl" (List [
-    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "maxBound"])]),App "UnGuardedRhs" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "head"]
-    )])]),App "List" (List [Reverse (MapCtor (Application (Concat (
-    List [List [App "Con" (List [App "UnQual" (List [App "Ident" (List
-    [CtorName])])])],MapField (App "Paren" (List [Application (List [
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "const"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "maxBound"])])]),App "Lit" (List [App "Int" (List [
-    FieldIndex])])])]))]))))])])]),App "Nothing" (List [])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Class/Arities.hs b/Data/Derive/Class/Arities.hs
deleted file mode 100644
--- a/Data/Derive/Class/Arities.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-
-module Data.Derive.Class.Arities where
-
-class Arities a where
-    arities :: a -> [Int]
diff --git a/Data/Derive/Class/Default.hs b/Data/Derive/Class/Default.hs
deleted file mode 100644
--- a/Data/Derive/Class/Default.hs
+++ /dev/null
@@ -1,5 +0,0 @@
-
-module Data.Derive.Class.Default where
-
-class Default a where
-    def :: a
diff --git a/Data/Derive/DSL/Apply.hs b/Data/Derive/DSL/Apply.hs
deleted file mode 100644
--- a/Data/Derive/DSL/Apply.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
-
-module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where
-
-import Data.Derive.DSL.HSE
-import Data.Derive.DSL.DSL
-import Data.List
-import Data.Generics.Uniplate.DataOnly
-
-
-apply :: DSL -> Input -> Out
-apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}
-
-
-env = Env
-    (error "Env.envInput: uninitialised")
-    (error "Env.envCtor: uninitialised")
-    (error "Env.envField: uninitialised")
-    (error "Env.envFold: uninitialised")
-
-
-data Env = Env  {envInput :: Input
-                ,envCtor :: Ctor
-                ,envField :: Integer
-                ,envFold :: (Output,Output) }
-
-applyEnv :: DSL -> Env -> Output
-applyEnv dsl env@(Env input ctor field fold) = f dsl
-    where
-    f (Instance ctx hd body) =
-        OApp "InstDecl"
-            [out (Nothing :: Maybe Overlap)
-            ,out ([] :: [TyVarBind])
-            ,out
-                [ClassA (UnQual $ Ident c) [TyVar $ Ident v]
-                | let seen = [x | TyVar (Ident x) <- universeBi $ concatMap ctorDeclFields $ dataCtors input]
-                , v <- dataDeclVarsStar input `intersect` seen
-                , c <- ctx]
-            ,out $ UnQual $ Ident hd
-            ,out [TyParen $ foldl TyApp
-                (TyCon $ UnQual $ Ident $ dataName input)
-                (map tyVar $ dataDeclVars input)]
-            ,f body]
-
-    f (Application (f -> OList xs)) =
-        foldl1 (\a b -> OApp "App" [a,b]) xs
-
-    f (MapCtor dsl) = OList  [applyEnv dsl env{envCtor=c}
-         |  c <- dataCtors input]
-    f (MapField dsl) = OList [applyEnv dsl env{envField=i}
-         | i <- [1.. fromIntegral $ ctorArity ctor]]
-
-    f DataName = OString $ dataName input
-    f CtorName = OString $ ctorName ctor
-    f CtorArity = OInt $ ctorArity ctor
-    f CtorIndex = OInt $ ctorIndex input ctor
-    f FieldIndex = OInt $ field
-
-    f Head = fst fold
-    f Tail = snd fold
-    f (Fold cons (f -> OList xs)) =
-        foldr1 (\a b -> applyEnv cons env{envFold=(a,b)}) xs
-
-    f (List xs) = OList $ map f xs
-    f (Reverse (f -> OList xs)) = OList $ reverse xs
-    f (Concat (f -> OList [])) = OList []
-    f (Concat (f -> OList xs)) = foldr1 g xs
-            where  g (OList    x) (OList    y) = OList    (x++y)
-                   g (OString  x) (OString  y) = OString  (x++y)
-    f (String x) = OString x
-    f (Int x) = OInt x
-    f (ShowInt (f -> OInt x)) = OString $ show x
-    f (App x (f -> OList ys)) = OApp x ys
diff --git a/Data/Derive/DSL/DSL.hs b/Data/Derive/DSL/DSL.hs
deleted file mode 100644
--- a/Data/Derive/DSL/DSL.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
-module Data.Derive.DSL.DSL where
-
-import Data.Derive.DSL.HSE
-import Data.List
-import Data.Data
-import Data.Generics.Uniplate.DataOnly
-
-data DSL = App String DSL{-List-}
-         | Concat DSL
-         | Reverse DSL
-         | String String
-         | ShowInt DSL
-         | Int Integer
-         | List [DSL]
-         
-         | MapField DSL
-         | MapCtor DSL
-         | DataName
-         | CtorName
-         | CtorIndex
-         | CtorArity
-         | FieldIndex
-         
-         | Fold DSL DSL
-         | Head
-         | Tail
-         
-         | Instance [String] String DSL{-[InstDecl]-}
-         | Application DSL{-List-}
-           deriving (Data,Typeable,Show)
-
-box x = List [x]
-nil = List []
-append x y = Concat $ List [x,y]
-
-
-fromOut :: Output -> DSL
-fromOut (OApp x y) = App x (List $ map fromOut y)
-fromOut (OList x) = List (map fromOut x)
-fromOut (OString x) = String x
-fromOut x = error $ show ("fromOut",x)
-
-
-{-
-_1 s x1 = App s $ List [x1]
-_2 s x1 x2 = App s $ List [x1,x2]
-_3 s x1 x2 x3 = App s $ List [x1,x2,x3]
-_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]
-
-o x = fromOut $ out x
-
-dslEq :: DSL
-dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull
-    where
-        match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])
-        vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))
-        bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]
-        pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")
-        var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)
-
-        dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]
--}
-
-
-simplifyDSL :: DSL -> DSL
-simplifyDSL = transform f
-    where
-        f (Concat (List xs)) = case g xs of
-            [x] -> x
-            [] -> List []
-            xs -> Concat $ List xs
-        f x = x
-
-        g (List x:List y:zs) = g $ List (x++y):zs
-        g (List []:xs) = g xs
-        g (String "":xs) = g xs
-        g (x:xs) = x : g xs
-        g [] = []
-
-
-prettyTex :: DSL -> String
-prettyTex = f id . transform g
-    where
-        bracket x = "(" ++ x ++ ")"
-    
-        f b (App x (List [])) = x
-        f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs
-        f b (App x y) = b $ x ++ " " ++ f bracket y
-        f b (Concat x) = b $ "concat " ++ f bracket x
-        f b (Reverse x) = b $ "reverse " ++ f bracket x
-        f b (String x) = show x
-        f b (ShowInt x) = b $ "showInt " ++ f bracket x
-        f b (Int x) = show x
-        f b (List []) = "nil"
-        f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"
-        f b (MapField x) = b $ "mapField " ++ f bracket x
-        f b (MapCtor x) = b $ "mapCtor " ++ f bracket x
-        f b DataName = "dataName"
-        f b CtorName = "ctorName"
-        f b CtorIndex = "ctorIndex"
-        f b CtorArity = "ctorArity"
-        f b FieldIndex = "fieldIndex"
-        f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y
-        f b Head = "head"
-        f b Tail = "tail"
-        f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z
-        f b (Application x) = b $ "application " ++ f bracket x
-
-        g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y
-        g x = x
diff --git a/Data/Derive/DSL/Derive.hs b/Data/Derive/DSL/Derive.hs
deleted file mode 100644
--- a/Data/Derive/DSL/Derive.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-
-module Data.Derive.DSL.Derive(derive) where
-
-import Data.Derive.DSL.HSE
-import Data.Derive.DSL.DSL
-import Data.Derive.DSL.Apply
-import Data.List
-import Data.Char
-import Data.Maybe
-
-
-data Guess = Guess DSL
-           | GuessFld Int DSL
-           | GuessCtr Int Bool DSL  -- 0 based index, does it mention CtorName
-             deriving Show
-
-
-ctrNames = map ctorName $ dataCtors sample
-
-
-derive :: Out -> [DSL]
-derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]
-
-
-guess :: Output -> [Guess]
-guess (OApp "InstDecl" [OApp "Nothing" [], OList [], OList ctxt,name,typ,bod])
-    | OApp "UnQual" [OApp "Ident" [OString name]] <- name
-    , OList [OApp "TyParen" [OApp "TyApp"
-        [OApp "TyCon" [OApp "UnQual" [OApp "Ident" [OString nam]]]
-        ,OApp "TyVar" [OApp "Ident" [OString var]]]]] <- typ
-    , nam == dataName sample
-    , ctxt <- [x | OApp "ClassA" [OApp "UnQual" [OApp "Ident" [OString x]],_] <- map unparenA ctxt]
-    = [Guess $ Instance ctxt name y | Guess y <- guess bod]
-    where
-        unparenA (OApp "ParenA" [x]) = unparenA x
-        unparenA x = x
-
-guess (OList xs) = guessList xs
-guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)
-    
-guess (OString x) 
-    | Just i <- findIndex (`isSuffixOf` x) ctrNames = [GuessCtr i True $ String (take (length x - length (ctrNames !! i)) x) `append` CtorName]
-    | "Sample" `isSuffixOf` x = [Guess $ String (take (length x - 6) x) `append` DataName]
-    | otherwise =
-         [lift (\d -> append (String $ init x) (ShowInt d)) g | x /= "", isDigit (last x), g <- guess $ OInt $ read [last x]] ++
-         [Guess $ String x]
-
-guess (OInt i) =
-    [GuessFld (fromInteger i) FieldIndex | i `elem` [1,2]] ++
-    [GuessCtr 1 False CtorIndex | i == 1] ++
-    [GuessCtr 1 False CtorArity | i == 2] ++
-    [Guess $ Int i]
-
-guess x = error $ show ("fallthrough",x)
-
-
-{-
-First try and figure out runs to put them in to one possible option
-Then try and figure out similarities to give them the same type
--}
-guessList :: [Output] -> [Guess]
-guessList xs = mapMaybe sames $ map diffs $ sequence $ map guess xs
-    where
-        -- Given a list of guesses, try and collapse them into one coherent guess
-        -- Each input Guess will guess at a List, so compose with Concat
-        sames :: [Guess] -> Maybe Guess
-        sames xs = do
-            let (is,fs) = unzip $ map fromGuess xs
-            i <- maxim is
-            return $ toGuess i $ Concat $ List fs
-
-        -- Promote each Guess to be a list
-        diffs :: [Guess] -> [Guess]
-
-        diffs (GuessCtr 0 True x0:GuessCtr 1 True x1:GuessCtr 2 True x2:xs)
-            | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (MapCtor x1) : diffs xs
-            where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}
-        
-        diffs (GuessCtr 2 True x2:GuessCtr 1 True x1:GuessCtr 0 True x0:xs)
-            | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (Reverse $ MapCtor x1) : diffs xs
-            where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}
-        
-        diffs (GuessFld 1 x1:GuessFld 2 x2:xs)
-            | f 1 x1 == f 1 x2 = GuessCtr 1 False (MapField x2) : diffs xs
-            where f i x = applyEnv x env{envInput=sample, envField=i}
-        
-        diffs (GuessFld 2 x2:GuessFld 1 x1:xs)
-            | f 1 x1 == f 1 x2 = GuessCtr 1 False (Reverse $ MapField x2) : diffs xs
-            where f i x = applyEnv x env{envInput=sample, envField=i}
-
-        diffs (x:xs) = lift box x : diffs xs
-        diffs [] = []
-
-
-gssFold o@(OApp op [x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)
-    where
-        follow dir (OApp op2 [a,m2,b]) | op == op2 && m == m2 = a2 : follow dir b2
-            where (a2,b2) = if dir then (a,b) else (b,a)
-        follow dir x = [x]
-
-        f dir xs | length xs <= 2 = []
-        f dir xs = map (lift g) $ guess $ OList xs
-            where g = Fold (App op $ List [h,fromOut m,t])
-                  (h,t) = if dir then (Head,Tail) else (Tail,Head)
-
-gssFold _ = []
-
-
-gssApp (OApp "App" [OApp "App" [x,y],z]) = map (lift Application) $ guess $ OList $ fromApp x ++ [y,z]
-    where fromApp (OApp "App" [x,y]) = fromApp x ++ [y]
-          fromApp x = [x]
-gssApp _ = []
-    
-
-lift :: (DSL -> DSL) -> Guess -> Guess
-lift f x = toGuess a (f b)
-    where (a,b) = fromGuess x
-
-
-type GuessState = Maybe (Either Int (Int,Bool))
-
-fromGuess :: Guess -> (GuessState, DSL)
-fromGuess (Guess x) = (Nothing, x)
-fromGuess (GuessFld i x) = (Just (Left i), x)
-fromGuess (GuessCtr i b x) = (Just (Right (i,b)), x)
-
-toGuess :: GuessState -> DSL -> Guess
-toGuess Nothing = Guess
-toGuess (Just (Left i)) = GuessFld i
-toGuess (Just (Right (i,b))) = GuessCtr i b
-
-
--- return the maximum element, if one exists
-maxim :: [GuessState] -> Maybe GuessState
-maxim [] = Just Nothing
-maxim [x] = Just x
-maxim (Nothing:xs) = maxim xs
-maxim (x:Nothing:xs) = maxim $ x:xs
-maxim (x1:x2:xs) | x1 == x2 = maxim $ x1:xs
-maxim (Just (Right (i1,b1)):Just (Right (i2,b2)):xs) | i1 == i2 = maxim $ Just (Right (i1,max b1 b2)) : xs
-maxim _ = Nothing
diff --git a/Data/Derive/DSL/HSE.hs b/Data/Derive/DSL/HSE.hs
deleted file mode 100644
--- a/Data/Derive/DSL/HSE.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-
-module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where
-
-import Language.Haskell hiding (List, App, String, Int)
-import Data.Data
-import Data.Generics.Uniplate.DataOnly
-import Data.Maybe
-import Data.List
-import Data.Function
-import Control.Monad.Trans.State
-
-
----------------------------------------------------------------------
--- EXAMPLES
-
-{-
--- data List a = Nil | Cons a (List a)
-list :: Input
-list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]
--}
-
-
--- data Sample a = First | Second a a | Third a
-sample :: Input
-sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs []
-    where
-        ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]
-        ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ tyVar "a"
-
-
----------------------------------------------------------------------
--- UTILITIES
-
-outEq :: Out -> Out -> Bool
-outEq = (==) `on` transformBi (const sl)
-
----------------------------------------------------------------------
-
-showOut x = unlines $ map prettyPrint x
-
-
-type Input = DataDecl
-type Ctor = CtorDecl
-
-dataName = dataDeclName
-dataVars = length . dataDeclVars
-dataCtors = dataDeclCtors
-ctorName = ctorDeclName
-ctorArity = fromIntegral . ctorDeclArity
-
-ctorIndex :: Input -> Ctor -> Integer
-ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat
-
-
-toInput :: DataDecl -> Input
-toInput x = x
-
-
-type Out = [Decl]
-
-
-
-data Output = OString String
-            | OInt Integer
-            | OApp String [Output]
-            | OList [Output]
-            | OIgnore
-            | OCustom String
-              deriving (Eq,Show,Data,Typeable)
-
-
-toOutput :: Data a => a -> Output
-toOutput x
-    | t == typeOf "" = OString $ coerce x
-    | c == "[]" = OList $ fList x
-    | t == typeOf sl = OIgnore
-    | t == typeOf (1 :: Integer) = OInt $ coerce x
-    | otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)
-    where
-        t = typeOf x
-        c = show $ fst $ splitTyConApp t
-
-        fList :: Data a => a -> [Output]
-        fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]
-
-fromOutput :: Data a => Output -> a
-fromOutput (OList xs) = res
-    where res = f xs
-          f [] = fromConstr $ readCon dat "[]"
-          f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"
-          dat = dataTypeOf res
-          
-          g :: (Data a, Data b) => Output -> a -> b
-          g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x
-
-fromOutput (OApp str args) = res
-    where dat = dataTypeOf res
-          res = evalState (fromConstrM f $ readCon dat str) args
-          f :: Data a => State [Output] a
-          f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else
-                              do x:xs <- get; put xs; return $ fromOutput x
-
-fromOutput (OString x) = coerce x
-fromOutput (OInt x) = coerce x
-
-
-coerce x = fromMaybe (error "Error in coerce") $ cast x
-readCon dat x = fromMaybe (error $ "Error in readCon, " ++ x) $ readConstr dat x
-out x = toOutput x
-fromState :: State a x -> x
-fromState = undefined
diff --git a/Data/Derive/DSL/SYB.hs b/Data/Derive/DSL/SYB.hs
deleted file mode 100644
--- a/Data/Derive/DSL/SYB.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-{-# LANGUAGE RelaxedPolyRec, RankNTypes, ScopedTypeVariables #-}
-{- OPTIONS_GHC -fglasgow-exts -}
-
-module Data.Derive.DSL.SYB(dslSYB) where
-
-import Data.Derive.DSL.HSE
-import qualified Language.Haskell.Exts as H
-import Data.Derive.DSL.DSL
-import Control.Monad.Trans.State
-import Control.Monad
-import Data.Generics
-import Data.Maybe
-
-
-dslSYB :: DSL -> Maybe Out
-dslSYB = syb
-
-
-syb :: Data a => DSL -> Maybe a
-syb = dsimple & dlistAny & dapp -- & derr
-
-lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)
-lift f = maybe Nothing id . cast . f
-
-(&) a b x = a x `mplus` b x
-
-
-dlistAny :: forall a . Data a => DSL -> Maybe a
-dlistAny x | isNothing con = Nothing
-           | otherwise = res 
-    where
-        con = readConstr dat "(:)"
-        val = fromConstr (fromJust con) :: a
-        
-        dat = dataTypeOf (undefined :: a)
-        
-        res = gmapQi 0 f val
-
-        f :: Data d => d -> Maybe a
-        f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]
-
-
-dlist :: Data a => DSL -> Maybe [a]
-dlist x = do
-    List xs <- return x
-    mapM syb xs
-
-
-dapp :: forall a . Data a => DSL -> Maybe a
-dapp x = do
-    App name (List args) <- return x
-    let dat = dataTypeOf (undefined :: a)
-        (res,s) = runState (fromConstrM f $ readCon dat name) (True,args)
-    if fst s then Just res else Nothing
-    where
-        f :: forall b . Data b => State (Bool,[DSL]) b
-        f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl
-            else do
-                (b,x:xs) <- get
-                case syb x of
-                    Nothing -> do put (False,xs) ; return undefined
-                    Just y -> do put (b,xs) ; return y
-
-
-dsimple :: Data a => DSL -> Maybe a
-dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle
-
-
-dinstance :: DSL -> Maybe Decl
-dinstance x = do
-    Instance _ name bod <- return x
-    bod <- syb bod
-    return $ InstDecl sl Nothing []
-        [ClassA (UnQual $ Ident "Data") [TyVar $ Ident "d_type"]]
-        (UnQual $ Ident name) [TyVar $ Ident "d_type"]
-        bod
-
-
-dstring :: DSL -> Maybe String
-dstring x = do
-    String x <- return x
-    return x
-
-
-dmapctor :: DSL -> Maybe Exp
-dmapctor x = do
-    App "List" (List [MapCtor x]) <- return x
-    x <- syb x
-    return $ ListComp x [QualStmt $ Generator sl (PVar $ Ident "d_ctor")
-        (H.App (v "d_dataCtors") (Paren $ ExpTypeSig sl (v "undefined") (TyVar $ Ident "d_type")))]
-
-
-dsingle :: DSL -> Maybe Exp
-dsingle (App "Lit" (List [App "Int" (List [CtorArity])])) = Just $ Paren $ H.App (v "d_ctorArity") (v "d_ctor")
-dsingle (App "Lit" (List [App "Int" (List [CtorIndex])])) = Just $ Paren $ H.App (v "d_ctorIndex") (v "d_ctor")
-dsingle (App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []])) = Just $ Paren $
-    ExpTypeSig sl (H.App (v "d_ctorValue") (v "d_ctor")) (TyVar $ Ident "d_type")
-dsingle _ = Nothing
-
-
-dapplication :: DSL -> Maybe Exp
-dapplication x = do
-    Application (List xs) <- return x
-    syb $ f xs
-    where
-        f (x:y:z) = f (App "App" (List [x,y]) : z)
-        f [x] = x
-
-
-v = Var . UnQual . Ident
diff --git a/Data/Derive/Data.hs b/Data/Derive/Data.hs
deleted file mode 100644
--- a/Data/Derive/Data.hs
+++ /dev/null
@@ -1,154 +0,0 @@
-module Data.Derive.Data(makeData) where
-{-
-import Data.Data
-
-example :: Custom
-
-instance (Data a, Typeable a) => Data (Sample a) where
-    gfoldl k r (First) = r First
-    gfoldl k r (Second x1 x2) = r Second `k` x1 `k` x2
-    gfoldl k r (Third x1) = r Third `k` x1
-
-    gunfold k z c = case constrIndex c - 1 of
-        0 -> z First
-        1 -> const k 1 $ const k 2 $ z Second
-        2 -> const k 1 $ z Third
-        i -> error $ ("Data.gunfold for Sample" ++ ", unknown index: ") ++ show i
-
-    toConstr x@First{}  = indexConstr (dataTypeOf x) (0+1)
-    toConstr x@Second{} = indexConstr (dataTypeOf x) (1+1)
-    toConstr x@Third{}  = indexConstr (dataTypeOf x) (2+1)
-
-    dataTypeOf _ = ty
-        where ty = mkDataType $(dataName)
-                   [mkConstr ty "First"  $(ctorFields 0) $(ctorFixity 0)
-                   ,mkConstr ty "Second" $(ctorFields 1) $(ctorFixity 1)
-                   ,mkConstr ty "Third"  $(ctorFields 2) $(ctorFixity 2)]
-
-test :: Computer
-
-instance Data Computer where
-    gfoldl k r (Laptop x1 x2) = r Laptop `k` x1 `k` x2
-    gfoldl k r (Desktop x1) = r Desktop `k` x1
-    gunfold k z c = case constrIndex c - 1 of
-        0 -> k $ k $ z Laptop
-        1 -> k $ z Desktop
-        i -> error $ "Data.gunfold for Computer, unknown index: " ++ show i
-    toConstr x@Laptop{} = indexConstr (dataTypeOf x) 1
-    toConstr x@Desktop{} = indexConstr (dataTypeOf x) 2
-    dataTypeOf _ = ty
-      where ty = mkDataType "Example.Computer"
-                 [mkConstr ty "Laptop" ["weight", "speed"] Prefix
-                 ,mkConstr ty "Desktop" ["speed"] Prefix]
-
--}
-
-import Data.Derive.DSL.HSE
-import qualified Language.Haskell as H
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeData :: Derivation
-makeData = derivationCustomDSL "Data" custom $
-    List [Instance ["Data","Typeable"] "Data" (List [App "InsDecl" (
-    List [App "FunBind" (List [MapCtor (App "Match" (List [App "Ident"
-    (List [String "gfoldl"]),List [App "PVar" (List [App "Ident" (List
-    [String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])]
-    ),App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
-    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
-    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App
-    "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App
-    "Ident" (List [String "k"])])]),Head])) (Concat (List [Reverse (
-    MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "r"])])]),App "Con" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])])])])]]))]),App "Nothing" (List [])]))])
-    ]),App "InsDecl" (List [App "FunBind" (List [List [App "Match" (
-    List [App "Ident" (List [String "gunfold"]),List [App "PVar" (List
-    [App "Ident" (List [String "k"])]),App "PVar" (List [App "Ident" (
-    List [String "z"])]),App "PVar" (List [App "Ident" (List [String
-    "c"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
-    "Case" (List [App "InfixApp" (List [App "App" (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "constrIndex"]
-    )])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "c"])])])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List
-    [Int 1])])]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (
-    List [App "Signless" (List []),App "Int" (List [CtorIndex])]),App
-    "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
-    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String "$"
-    ])])]),Tail])) (Concat (List [MapField (Application (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "const"
-    ])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "k"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])]
-    )),List [App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "z"])])]),App "Con" (List [App "UnQual" (
-    List [App "Ident" (List [CtorName])])])])]]))]),App "Nothing" (
-    List [])])),List [App "Alt" (List [App "PVar" (List [App "Ident" (
-    List [String "i"])]),App "UnGuardedRhs" (List [App "InfixApp" (
-    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "error"])])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String "$"])])]),App "InfixApp" (List [App "Paren"
-    (List [App "InfixApp" (List [App "Lit" (List [App "String" (List [
-    Concat (List [String "Data.gunfold for ",DataName])])]),App
-    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
-    "++"])])]),App "Lit" (List [App "String" (List [String
-    ", unknown index: "])])])]),App "QVarOp" (List [App "UnQual" (List
-    [App "Symbol" (List [String "++"])])]),App "App" (List [App "Var"
-    (List [App "UnQual" (List [App "Ident" (List [String "show"])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i"
-    ])])])])])])]),App "Nothing" (List [])])]])])]),App "Nothing" (
-    List [])])]])]),App "InsDecl" (List [App "FunBind" (List [MapCtor
-    (App "Match" (List [App "Ident" (List [String "toConstr"]),List [
-    App "PAsPat" (List [App "Ident" (List [String "x"]),App "PRec" (
-    List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []]
-    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Application
-    (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "indexConstr"])])]),App "Paren" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "dataTypeOf"])])]),App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "x"])])])])]),App "Paren" (List [App
-    "InfixApp" (List [App "Lit" (List [App "Int" (List [CtorIndex])]),
-    App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
-    "+"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])])]),App
-    "Nothing" (List [])]))])]),App "InsDecl" (List [App "FunBind" (
-    List [List [App "Match" (List [App "Ident" (List [String
-    "dataTypeOf"]),List [App "PWildCard" (List [])],App "Nothing" (
-    List []),App "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "ty"])])])]),App "Just" (List [App
-    "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App
-    "Ident" (List [String "ty"])]),App "UnGuardedRhs" (List [
-    Application (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "mkDataType"])])]),App "SpliceExp" (List [
-    App "ParenSplice" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "dataName"])])])])]),App "List" (List [
-    MapCtor (Application (List [App "Var" (List [App "UnQual" (List [
-    App "Ident" (List [String "mkConstr"])])]),App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "ty"])])]),App "Lit" (
-    List [App "String" (List [CtorName])]),App "SpliceExp" (List [App
-    "ParenSplice" (List [App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "ctorFields"])])]),App
-    "Lit" (List [App "Int" (List [CtorIndex])])])])]),App "SpliceExp"
-    (List [App "ParenSplice" (List [App "App" (List [App "Var" (List [
-    App "UnQual" (List [App "Ident" (List [String "ctorFixity"])])]),
-    App "Lit" (List [App "Int" (List [CtorIndex])])])])])]))])])]),App
-    "Nothing" (List [])])]])])])]])])])]
--- GENERATED STOP
-
-
-custom d = customContext context d . customSplice splice d
-
-splice :: FullDataDecl -> Exp -> Exp
-splice d x | x ~= "dataName" = H.Lit $ H.String $ prettyPrint (fst d) ++ "." ++ dataDeclName (snd d)
-splice d (H.App x (H.Lit (H.Int y)))
-    | x ~= "ctorFields" = H.List $ [H.Lit $ H.String a | (a,_) <- ctorDeclFields ctor, a /= ""]
-    | x ~= "ctorFixity" = Con (UnQual (Ident "Prefix"))
-    where ctor = dataDeclCtors (snd d) !! fromInteger y
-
-context :: FullDataDecl -> Context -> Context
-context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVarsStar $ snd d, t <- ["Typeable","Data"]]
diff --git a/Data/Derive/DataAbstract.hs b/Data/Derive/DataAbstract.hs
deleted file mode 100644
--- a/Data/Derive/DataAbstract.hs
+++ /dev/null
@@ -1,59 +0,0 @@
-{-|
-    For deriving Data on abstract data types.
--}
-module Data.Derive.DataAbstract(makeDataAbstract) where
-{-
-import Data.Data(Data(..))
-
-example :: Custom
-
-instance Typeable a => Data (Sample a) where
-    gfoldl k r x = r x
-    gunfold = error "Data.gunfold not implemented on abstract data type: Sample"
-    toConstr = error "Data.gunfold not implemented on abstract data type: Sample"
-    dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"
-
--}
-
-import Data.Derive.DSL.HSE
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeDataAbstract :: Derivation
-makeDataAbstract = derivationCustomDSL "DataAbstract" custom $
-    List [Instance ["Typeable"] "Data" (List [App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "gfoldl"]),List [App "PVar" (List [App "Ident" (List [
-    String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])])
-    ,App "PVar" (List [App "Ident" (List [String "x"])])],App
-    "Nothing" (List []),App "UnGuardedRhs" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "r"])])
-    ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "x"])])])])]),App "Nothing" (List [])])]])]),App "InsDecl" (List [
-    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "gunfold"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var"
-    (List [App "UnQual" (List [App "Ident" (List [String "error"])])])
-    ,App "Lit" (List [App "String" (List [Concat (List [String
-    "Data.gunfold not implemented on abstract data type: ",DataName])]
-    )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App
-    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "toConstr"])]),App "UnGuardedRhs" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "error"
-    ])])]),App "Lit" (List [App "String" (List [Concat (List [String
-    "Data.gunfold not implemented on abstract data type: ",DataName])]
-    )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App
-    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "dataTypeOf"])]),App "UnGuardedRhs" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "error"
-    ])])]),App "Lit" (List [App "String" (List [Concat (List [String
-    "Data.gunfold not implemented on abstract data type: ",DataName])]
-    )])])]),App "Nothing" (List [])])])])]
--- GENERATED STOP
-
-custom = customContext context
-
-context :: FullDataDecl -> Context -> Context
-context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
diff --git a/Data/Derive/Default.hs b/Data/Derive/Default.hs
deleted file mode 100644
--- a/Data/Derive/Default.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Data.Derive.Default where
-{-
-import "derive" Data.Derive.Class.Default
-
-example :: Sample
-
-instance Default a => Default (Sample a) where
-    def = head [First, Second (const def 1) (const def 2), Third (const def 1)]
-
--}
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeDefault :: Derivation
-makeDefault = derivationDSL "Default" dslDefault
-
-dslDefault =
-    List [Instance ["Default"] "Default" (List [App "InsDecl" (List [
-    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "def"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "head"])])]),
-    App "List" (List [MapCtor (Application (Concat (List [List [App
-    "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])])
-    ],MapField (App "Paren" (List [Application (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [String "const"])])]),App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "def"])
-    ])]),App "Lit" (List [App "Int" (List [FieldIndex])])])]))])))])])
-    ]),App "Nothing" (List [])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Enum.hs b/Data/Derive/Enum.hs
deleted file mode 100644
--- a/Data/Derive/Enum.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-module Data.Derive.Enum where
-{-
-import Prelude
-
-example :: Sample
-
-instance Enum (Sample a) where
-    toEnum 0 = First{}
-    toEnum 1 = Second{}
-    toEnum 2 = Third{}
-    toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "Sample"
-
-    fromEnum (First{}) = 0
-    fromEnum (Second{}) = 1
-    fromEnum (Third{}) = 2
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeEnum :: Derivation
-makeEnum = derivationDSL "Enum" dslEnum
-
-dslEnum =
-    List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind"
-    (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List
-    [String "toEnum"]),List [App "PLit" (List [App "Signless" (List []
-    ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [
-    App "Ident" (List [CtorName])]),List []])]),App "Nothing" (List []
-    )])),List [App "Match" (List [App "Ident" (List [String "toEnum"])
-    ,List [App "PVar" (List [App "Ident" (List [String "n"])])],App
-    "Nothing" (List []),App "UnGuardedRhs" (List [App "InfixApp" (List
-    [App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "error"])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol"
-    (List [String "$"])])]),Fold (App "InfixApp" (List [Head,App
-    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
-    "++"])])]),Tail])) (List [App "Lit" (List [App "String" (List [
-    String "toEnum "])]),App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "n"])])])]),
-    App "Lit" (List [App "String" (List [String ", not defined for "])
-    ]),App "Lit" (List [App "String" (List [DataName])])])])]),App
-    "Nothing" (List [])])]])])]),App "InsDecl" (List [App "FunBind" (
-    List [MapCtor (App "Match" (List [App "Ident" (List [String
-    "fromEnum"]),List [App "PParen" (List [App "PRec" (List [App
-    "UnQual" (List [App "Ident" (List [CtorName])]),List []])])],App
-    "Nothing" (List []),App "UnGuardedRhs" (List [App "Lit" (List [App
-    "Int" (List [CtorIndex])])]),App "Nothing" (List [])]))])])])]
--- GENERATED STOP
diff --git a/Data/Derive/EnumCyclic.hs b/Data/Derive/EnumCyclic.hs
deleted file mode 100644
--- a/Data/Derive/EnumCyclic.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-module Data.Derive.EnumCyclic where
-{-
-import Prelude(Enum)
-
-example :: Sample
-
-instance Enum (Sample a) where
-    toEnum 0 = First{}
-    toEnum 1 = Second{}
-    toEnum 2 = Third{}
-    toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample"
-
-    fromEnum (First{}) = 0
-    fromEnum (Second{}) = 1
-    fromEnum (Third{}) = 2
-
-
-    succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)
-        where b = fromEnum a
-
-    pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)
-        where b = fromEnum a
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeEnumCyclic :: Derivation
-makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic
-
-dslEnumCyclic =
-    List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind"
-    (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List
-    [String "toEnum"]),List [App "PLit" (List [App "Signless" (List []
-    ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [
-    App "Ident" (List [CtorName])]),List []])]),App "Nothing" (List []
-    )])),List [App "Match" (List [App "Ident" (List [String "toEnum"])
-    ,List [App "PVar" (List [App "Ident" (List [String "n"])])],App
-    "Nothing" (List []),App "UnGuardedRhs" (List [App "InfixApp" (List
-    [App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "error"])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol"
-    (List [String "$"])])]),Fold (App "InfixApp" (List [Head,App
-    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
-    "++"])])]),Tail])) (List [App "Lit" (List [App "String" (List [
-    String "toEnum "])]),App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "n"])])])]),
-    App "Lit" (List [App "String" (List [Concat (List [String
-    ", not defined for ",DataName])])])])])]),App "Nothing" (List [])]
-    )]])])]),App "InsDecl" (List [App "FunBind" (List [MapCtor (App
-    "Match" (List [App "Ident" (List [String "fromEnum"]),List [App
-    "PParen" (List [App "PRec" (List [App "UnQual" (List [App "Ident"
-    (List [CtorName])]),List []])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "Lit" (List [App "Int" (List [CtorIndex]
-    )])]),App "Nothing" (List [])]))])]),App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "succ"]),List [App "PVar" (List [App "Ident" (List [String
-    "a"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
-    "If" (List [App "InfixApp" (List [App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "b"])])]),App "QVarOp" (List [App
-    "UnQual" (List [App "Symbol" (List [String "=="])])]),App "App" (
-    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "length"])])]),App "List" (List [MapCtor (App "RecConstr" (
-    List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []]
-    ))])])]),App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "toEnum"])])]),App "Lit" (List [App "Int" (
-    List [Int 0])])]),App "App" (List [App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "toEnum"])])]),App "Paren" (List [
-    App "InfixApp" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "b"])])]),App "QVarOp" (List [App "UnQual" (
-    List [App "Symbol" (List [String "+"])])]),App "Lit" (List [App
-    "Int" (List [Int 1])])])])])])]),App "Just" (List [App "BDecls" (
-    List [List [App "PatBind" (List [App "PVar" (List [App "Ident" (
-    List [String "b"])]),App "UnGuardedRhs" (List [App "App" (List [
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "a"])])])])]),App "Nothing" (List [])])]])])])]])]),
-    App "InsDecl" (List [App "FunBind" (List [List [App "Match" (List
-    [App "Ident" (List [String "pred"]),List [App "PVar" (List [App
-    "Ident" (List [String "a"])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "If" (List [App "InfixApp" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "b"])])
-    ]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
-    String "=="])])]),App "Lit" (List [App "Int" (List [Int 0])])]),
-    App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "toEnum"])])]),App "Paren" (List [App "App" (List [
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [
-    App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])
-    ])]),App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "toEnum"])])]),App "Paren" (List [App
-    "InfixApp" (List [App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "b"])])]),App "QVarOp" (List [App "UnQual" (List [
-    App "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (
-    List [Int 1])])])])])])]),App "Just" (List [App "BDecls" (List [
-    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
-    String "b"])]),App "UnGuardedRhs" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "a"])])])])]),App "Nothing" (List [])])]])])])]])])]
-    )]
--- GENERATED STOP
diff --git a/Data/Derive/Eq.hs b/Data/Derive/Eq.hs
deleted file mode 100644
--- a/Data/Derive/Eq.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-module Data.Derive.Eq where
-{-
-import Prelude
-
-example :: Sample
-
-instance (Eq a) => Eq (Sample a) where
-    First == First = True
-    Second x1 x2 == Second y1 y2 = x1 == y1 && x2 == y2 && True
-    Third x1 == Third y1 = x1 == y1 && True
-    _ == _ | length [First{},Second{},Third{}] > 1 = False
-
-test :: Assoced
-instance Eq typ => Eq (Assoced typ) where
-    Assoced x1 x2 == Assoced y1 y2 = x1 == y1 && x2 == y2
-
-test :: TwoParam
-instance Eq b => Eq (TwoParam a b) where
-    TwoParam x1 == TwoParam y1 = x1 == y1
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeEq :: Derivation
-makeEq = derivationDSL "Eq" dslEq
-
-dslEq =
-    List [Instance ["Eq"] "Eq" (List [App "InsDecl" (List [App
-    "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App
-    "Symbol" (List [String "=="]),List [App "PApp" (List [App "UnQual"
-    (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List
-    [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]
-    )]))]),App "PApp" (List [App "UnQual" (List [App "Ident" (List [
-    CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat
-    (List [String "y",ShowInt FieldIndex])])]))])],App "Nothing" (List
-    []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
-    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
-    "&&"])])]),Tail])) (Concat (List [MapField (App "InfixApp" (List [
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
-    List [String "x",ShowInt FieldIndex])])])]),App "QVarOp" (List [
-    App "UnQual" (List [App "Symbol" (List [String "=="])])]),App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
-    String "y",ShowInt FieldIndex])])])])])),List [App "Con" (List [
-    App "UnQual" (List [App "Ident" (List [String "True"])])])]]))]),
-    App "Nothing" (List [])])),List [App "Match" (List [App "Symbol" (
-    List [String "=="]),List [App "PWildCard" (List []),App
-    "PWildCard" (List [])],App "Nothing" (List []),App "GuardedRhss" (
-    List [List [App "GuardedRhs" (List [List [App "Qualifier" (List [
-    App "InfixApp" (List [App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "length"])])]),App
-    "List" (List [MapCtor (App "RecConstr" (List [App "UnQual" (List [
-    App "Ident" (List [CtorName])]),List []]))])]),App "QVarOp" (List
-    [App "UnQual" (List [App "Symbol" (List [String ">"])])]),App
-    "Lit" (List [App "Int" (List [Int 1])])])])],App "Con" (List [App
-    "UnQual" (List [App "Ident" (List [String "False"])])])])]]),App
-    "Nothing" (List [])])]])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Fold.hs b/Data/Derive/Fold.hs
deleted file mode 100644
--- a/Data/Derive/Fold.hs
+++ /dev/null
@@ -1,67 +0,0 @@
--- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>
-
-{-|
-    A pseudo derivation.  Derive a (non-recursive) fold function for 
-    the type which takes one function per alternative constructor.  Each
-    function takes the same arguments as the constructor and returns
-    a value.  When applied to a value the fold function applies the
-    function for the matching constructor to the constructor fields.
-    This provides a first-class alternative to pattern matching to
-    deconstruct the data type.
--}
-module Data.Derive.Fold(makeFold) where
-{-
-test :: Computer
-
-foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a
-foldComputer f _ (Laptop x1 x2) = f x1 x2
-foldComputer _ f (Desktop x1) = f x1
-
-test :: Assoced
-
-foldAssoced :: (typ -> String -> a) -> Assoced typ -> a
-foldAssoced f (Assoced x1 x2) = f x1 x2
-
-test :: Either
-
-foldEither :: (a -> c) -> (b -> c) -> Either a b -> c
-foldEither f _ (Left x1) = f x1
-foldEither _ f (Right x1) = f x1
-
-test :: Bool
-
-foldBool :: a -> a -> Bool -> a
-foldBool f _ False = f
-foldBool _ f True = f
-
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-import Data.List
-import Data.Generics.Uniplate.DataOnly
-
-
-makeFold :: Derivation
-makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d
-
-
-mkFold :: DataDecl -> [Decl]
-mkFold d | isIdent $ dataDeclName d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f [0..] $ dataDeclCtors d]
-         | otherwise = []
-    where
-        n = "fold" ++ title (dataDeclName d)
-        f i c = Match sl (name n) pat Nothing (UnGuardedRhs bod) Nothing
-            where pat = replicate i PWildCard ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) PWildCard ++
-                        [PParen $ PApp (qname $ ctorDeclName c) (map pVar vars)]
-                  bod = apps (var "f") (map var vars)
-                  vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]
-
-
-foldType :: DataDecl -> Type
-foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]
-    where
-        dt = dataDeclType d
-        v = head $ map (tyVar . return) ['a'..] \\ universe dt
-        f c = TyParen $ tyFun $ map snd (ctorDeclFields c) ++ [v]
-
diff --git a/Data/Derive/Foldable.hs b/Data/Derive/Foldable.hs
deleted file mode 100644
--- a/Data/Derive/Foldable.hs
+++ /dev/null
@@ -1,55 +0,0 @@
-{-
-    This module is not written/maintained by the usual Data.Derive author.
-
-    MAINTAINER: Twan van Laarhoven 
-    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
-
-    Please send all patches to this module to Neil (ndmitchell -at- gmail),
-    and CC Twan.
--}
-
-module Data.Derive.Foldable(makeFoldable, makeFoldableN) where
-
-{-
-import Data.Foldable(Foldable)
-import qualified Data.Foldable(foldr)
-
-test :: FailList
-instance Foldable (FailList t1) where
-    foldr _  b Zoro = b
-    foldr _  b (Fial _) = b
-    foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2)
-
-test :: Sample
-instance Foldable Sample where
-    foldr _  b First = b
-    foldr _f b (Second a1 a2) = _f a1 (_f a2 b)
-    foldr _f b (Third a1) = _f a1 b
-
-test :: Either
-instance Foldable (Either t1) where
-    foldr _  b (Left _) = b
-    foldr _f b (Right a1) = _f a1 b
--}
-
-import Data.Derive.Internal.Traversal
-import Data.Derive.Internal.Derivation
-import Language.Haskell
-
-
-makeFoldable :: Derivation
-makeFoldable = makeFoldableN 1
-
-makeFoldableN :: Int -> Derivation
-makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable"
-
-foldrTraversal = defaultTraversalType
-        { traversalName   = Qual (ModuleName "Data.Foldable") (Ident "foldr")
-        , traversalFunc   = \n a -> appP (var "flip") $ appP (Var n) a
-        , traversalPlus   = fail "variable used in multiple positions in a data type"
-        , traversalId     = App (var "flip") (var "const")
-        , traverseTuple   =         foldr (.:) $ var "id"
-        , traverseCtor    = const $ foldr (.:) $ var "id"
-        , traverseFunc    = \pat rhs -> Match sl (name "") [pVar "_f", pVar "b", pat] Nothing (UnGuardedRhs $ appP rhs (var "b")) Nothing
-        }
-    where a .: b = InfixApp (paren a) (qvop ".") (paren b)
diff --git a/Data/Derive/From.hs b/Data/Derive/From.hs
deleted file mode 100644
--- a/Data/Derive/From.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-|
-    A pseudo derivation.  For each constructor in the data type,
-    deriving @From@ generates @from@/CtorName/ which extracts the
-    components if given the appropriate constructor, and crashes
-    otherwise.  Unlike the DrIFT @\"From\"@ derivation, our version
-    works for all constructors - zero-arity constructors always return
-    @()@, arity-one constructors return the contained value, and all
-    others return a tuple with all the components.
--}
-
-module Data.Derive.From(makeFrom) where
-
-{-
-
-test :: Sample
-
-fromFirst :: Sample a -> ()
-fromFirst First = ()
-fromFirst _ = error "fromFirst failed, not a First"
-
-fromSecond :: Sample a -> (a, a)
-fromSecond (Second x1 x2) = (x1,x2)
-fromSecond _ = error "fromSecond failed, not a Second"
-
-fromThird :: Sample a -> a
-fromThird (Third x1) = x1
-fromThird _ = error "fromThird failed, not a Third"
-
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-
-
-makeFrom :: Derivation
-makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d
-
-
-makeFromCtor :: DataDecl -> CtorDecl -> [Decl]
-makeFromCtor d c | isIdent n = [TypeSig sl [name from] typ, FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]
-                 | otherwise = []
-    where
-        n = ctorDeclName c
-        from = "from" ++ n
-
-        typ = TyFun (dataDeclType d)
-            (tyTuple $ map snd $ ctorDeclFields c)
-
-        match = Match sl (name from) [pat] Nothing (UnGuardedRhs rhs) Nothing
-        pat = (length vars == 0 ? id $ PParen) $ PApp (qname n) (map pVar vars)
-        vars = take (length $ ctorDeclFields c) $ map ((:) 'x' . show) [1..]
-        rhs = valTuple $ map var vars
-
-        defMatch = Match sl (name from) [PWildCard] Nothing (UnGuardedRhs err) Nothing
-        err = App (var "error") $ Lit $ String $ from ++ " failed, not a " ++ n
-
-
-tyTuple [] = TyCon $ Special UnitCon
-tyTuple [x] = x
-tyTuple xs = TyTuple Boxed xs
-
-
-valTuple [] = Con $ Special UnitCon
-valTuple [x] = x
-valTuple xs = Tuple Boxed xs
diff --git a/Data/Derive/Functor.hs b/Data/Derive/Functor.hs
deleted file mode 100644
--- a/Data/Derive/Functor.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-{-
-    This module is not written/maintained by the usual Data.Derive author.
-
-    MAINTAINER: Twan van Laarhoven 
-    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
-
-    Please send all patches to this module to Neil (ndmitchell -at- gmail),
-    and CC Twan.
--}
-
--- NOTE: Cannot be guessed as it relies on type information
-
--- | Derives 'Functor', as discussed on the Haskell-prime mailing list:
--- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
-module Data.Derive.Functor(makeFunctor,makeFunctorN) where
-
-{-
-import Prelude
-
-test :: FailList
-instance Functor (FailList t1) where
-    fmap _  Zoro = Zoro
-    fmap _  (Fial a1) = Fial a1
-    fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2)
-
-test :: State
-instance Functor (State t1) where
-    fmap _f (StateT a1) = StateT (fmap _f . a1)
-
-test :: Sample
-instance Functor Sample where
-    fmap _  First = First
-    fmap _f (Second a1 a2) = Second (_f a1) (_f a2)
-    fmap _f (Third a1) = Third (_f a1)
--}
-
-
-import Data.Derive.Internal.Traversal
-import Data.Derive.Internal.Derivation
-import Language.Haskell
-
-
-makeFunctor :: Derivation
-makeFunctor = makeFunctorN 1
-
-makeFunctorN :: Int -> Derivation
-makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor"
-
-functorTraversal = defaultTraversalType
-        { traversalName   = qname "fmap"
-        , traverseArrow   = Just functorForArrowType
-        , traverseFunc    = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) Nothing
-        }
-
-functorForArrowType :: Exp -> Exp -> Exp
-functorForArrowType a b
-  | isId a && isId b  =  var "id"
-  | isId a            =  LeftSection b (qvop ".")
-  | isId b            =  RightSection (qvop ".") a
-  | otherwise         =  Lambda sl [pVar "arg"] $ b .: var "arg" .: a
- where isId = (var "id" ==)
-       a .: b = InfixApp (paren a) (qvop ".") (paren b)
diff --git a/Data/Derive/Has.hs b/Data/Derive/Has.hs
deleted file mode 100644
--- a/Data/Derive/Has.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-|
-    Has is a pseudo derivation.  For each field of any constructor of
-    the data type, Has generates @has@/FieldName/ which returns 'True'
-    if given the the given field is a member of the constructor of the
-    passed object, and 'False' otherwise.
--}
-module Data.Derive.Has(makeHas) where
-
-{-
-test :: Computer
-
-hasSpeed :: Computer -> Bool
-hasSpeed _ = True
-
-hasWeight :: Computer -> Bool
-hasWeight Laptop{} = True
-hasWeight _ = False
-
-test :: Sample
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-import Data.List
-
-
-makeHas :: Derivation
-makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d
-
-
-makeHasField :: DataDecl -> String -> [Decl]
-makeHasField d field = if isIdent field then [TypeSig sl [name has] typ, binds has ms] else []
-    where
-        has = "has" ++ title field
-        typ = TyFun (dataDeclType d) (tyCon "Bool")
-        (yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d
-        match pat val = ([pat], con val)
-
-        ms | null no = [match PWildCard "True"]
-           | otherwise = [match (PRec (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match PWildCard "False"]
diff --git a/Data/Derive/Instance/Arities.hs b/Data/Derive/Instance/Arities.hs
deleted file mode 100644
--- a/Data/Derive/Instance/Arities.hs
+++ /dev/null
@@ -1,14 +0,0 @@
--- GENERATED START
-{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}
-
-module Data.Derive.Instance.Arities where
-
-import Data.Derive.Class.Arities
-import Data.Derive.Internal.Instance
-
-instance Data d_type => Arities d_type where
-        arities _
-          = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |
-             d_ctor <- d_dataCtors (undefined :: d_type)]
-
--- GENERATED STOP
diff --git a/Data/Derive/Internal/Derivation.hs b/Data/Derive/Internal/Derivation.hs
deleted file mode 100644
--- a/Data/Derive/Internal/Derivation.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-
-module Data.Derive.Internal.Derivation(
-    Derivation(..),
-    derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,
-    customSplice, customContext
-    ) where
-
-import Data.DeriveDSL
-import Data.Derive.DSL.HSE
-import Data.Generics.Uniplate.DataOnly
-
-
-data Derivation = Derivation
-    {derivationName :: String
-    ,derivationOp :: Type -> (String -> Decl) -> FullDataDecl -> Either String [Decl]
-    }
-
-
-derivationParams :: String -> ([Type] -> (String -> Decl) -> FullDataDecl -> Either String [Decl]) -> Derivation
-derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs
-
-
-derivationCustom :: String -> (FullDataDecl -> Either String [Decl]) -> Derivation
-derivationCustom name op = derivationParams name $ \ty grab decs -> op decs
-
-
-derivationDSL :: String -> DSL -> Derivation
-derivationDSL name dsl = derivationCustomDSL name (const id) dsl
-
-
-derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation
-derivationCustomDSL name custom dsl = derivationCustom name $
-    \d -> case applyDSL dsl $ snd d of
-              Left x -> Left x
-              Right x -> Right $ simplify $ custom d x
-
-
-customSplice :: (FullDataDecl -> Exp -> Exp) -> (FullDataDecl -> [Decl] -> [Decl])
-customSplice custom d = transformBi f
-    where
-        f (SpliceExp (ParenSplice x)) = custom d x
-        f x = x
-
-
-customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl])
-customContext custom ds = map f
-    where
-        f (InstDecl sl a b ctx c d e) = InstDecl sl a b (custom ds ctx) c d e
-        f x = x
diff --git a/Data/Derive/Internal/Instance.hs b/Data/Derive/Internal/Instance.hs
deleted file mode 100644
--- a/Data/Derive/Internal/Instance.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# LANGUAGE ExistentialQuantification #-}
-
-module Data.Derive.Internal.Instance(
-    Data, d_ctorArity, d_ctorValue, d_dataCtors
-    ) where
-
-import Data.Data
-import Control.Monad
-import Control.Monad.Trans.State
-
-
-data Ctor = Ctor
-    {ctorType :: Box
-    ,ctorRep :: Constr}
-
-
-data Box = forall a . Data a => Box a
-
-
-d_ctorArity :: Ctor -> Int
-d_ctorArity Ctor{ctorType=Box t, ctorRep=rep} = flip execState 0 $
-    liftM (`asTypeOf` t) $
-    fromConstrM (modify (+1) >> return undefined) rep
-
-
-d_ctorValue :: Data a => Ctor -> a
-d_ctorValue = error "TODO: d_ctorValue"
-
-
-d_dataCtors :: Data a => a -> [Ctor]
-d_dataCtors x
-    | not $ isAlgType t = error "d_dataCtors only works on algebraic data types"
-    | otherwise = map (Ctor $ Box x) $ dataTypeConstrs t
-    where t = dataTypeOf x
diff --git a/Data/Derive/Internal/Traversal.hs b/Data/Derive/Internal/Traversal.hs
deleted file mode 100644
--- a/Data/Derive/Internal/Traversal.hs
+++ /dev/null
@@ -1,211 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-
-    This module is not written/maintained by the usual Data.Derive author.
-
-    MAINTAINER: Twan van Laarhoven 
-    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
-
-    Please send all patches to this module to Neil (ndmitchell -at- gmail),
-    and CC Twan.
--}
-
--- NOTE: Cannot be guessed as it relies on type information
-
--- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:
--- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
-module Data.Derive.Internal.Traversal(
-        TraveralType(..), defaultTraversalType,
-        traversalDerivation1,
-        traversalInstance, traversalInstance1,
-        deriveTraversal
-    ) where
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-import Data.List
-import qualified Data.Set as S
-import Control.Monad.Trans.Writer
-import Control.Applicative
-import Data.Generics.Uniplate.DataOnly
-import Data.Maybe
-import Prelude
-
----------------------------------------------------------------------------------
--- Information datatype, public interface
-
--- | An expression representing a traversal of a subpart of the data
-type Trav = Exp
-
--- | What kind of traversal are we deriving?
-data TraveralType = TraveralType
-        { traversalArg    :: Int                     -- ^ On what position are we traversing?
-        , traversalCo     :: Bool                    -- ^ covariant?
-        , traversalName   :: QName                   -- ^ name of the traversal function
-        , traversalId     :: Trav                    -- ^ Identity traversal
-        , traversalDirect :: Trav                    -- ^ Traversal of 'a'
-        , traversalFunc   :: QName -> Trav -> Trav  -- ^ Apply the sub-traversal function
-        , traversalPlus   :: Trav -> Trav -> Trav    -- ^ Apply two non-identity traversals in sequence
-        , traverseArrow   :: Maybe (Trav -> Trav -> Trav)    -- ^ Traverse a function type
-        , traverseTuple   :: [Exp] -> Exp            -- ^ Construct a tuple from applied traversals
-        , traverseCtor    :: String -> [Exp] -> Exp  -- ^ Construct a data type from applied traversals
-        , traverseFunc    :: Pat -> Exp -> Match     -- ^ Construct a clause of the traversal function
-        }
-
-defaultTraversalType = TraveralType
-        { traversalArg    = 1
-        , traversalCo     = False
-        , traversalName   = undefined -- prevent warnings
-        , traversalId     = var "id"
-        , traversalDirect = var "_f"
-        , traversalFunc   = \x y -> appP (Var x) y
-        , traversalPlus   = \x y -> apps (Con $ Special Cons) [paren x, paren y]
-        , traverseArrow   = Nothing
-        , traverseTuple   = Tuple Boxed
-        , traverseCtor    = \x y -> apps (con x) (map paren y)
-        , traverseFunc    = undefined
-        }
-
-data RequiredInstance = RequiredInstance
-        { _requiredDataArg  :: String -- ^ What argument of the current data type?
-        , _requiredPosition :: Int    -- ^ What argument position of that type?
-        }
-      deriving (Eq, Ord)
-
--- | Monad that collects required instances
-type WithInstances a = Writer (S.Set RequiredInstance) a
-
-
-vars f c n = [f $ c : show i | i <- [1..n]]
-
-
----------------------------------------------------------------------------------
--- Deriving traversals
-
-
--- | Derivation for a Traversable like class with just 1 method
-traversalDerivation1 :: TraveralType -> String -> Derivation
-traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm) 
-    where className n = nm ++ (if n > 1 then show n else "")
-
-
--- | Instance for a Traversable like class with just 1 method
-traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl]
-traversalInstance1 tt nm (_,dat)
-    | isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"
-    | dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"
-    | otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]
-
-
--- | Instance for a Traversable like class
-traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances Decl] -> [Decl]
-traversalInstance tt nameBase dat bodyM = [simplify $ InstDecl sl Nothing [] ctx nam args (map InsDecl body)]
-    where
-        (body, required) = runWriter (sequence bodyM)
-        ctx  = [ ClassA (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))
-               | RequiredInstance n p <- S.toList required
-               ]
-        vrs  = vars tyVar 't' (dataDeclArity dat)
-        (vrsBefore,_:vrsAfter) = splitAt (length vrs - traversalArg tt) vrs
-        className n = nameBase ++ (if n > 1 then show n else "")
-        nam = qname (className (traversalArg tt))
-        args = TyParen (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter
-
-
--- | Derive a 'traverse' like function
-deriveTraversal :: TraveralType -> DataDecl -> WithInstances Decl
-deriveTraversal tt dat = fun
-    where
-        fun  = (\xs -> FunBind [Match sl nam a b c d | Match _ _ a b c d <- xs]) <$> body
-        args = argPositions dat
-        nam = unqual $ traversalNameN tt $ traversalArg tt
-        body = mapM (deriveTraversalCtor tt args) (dataDeclCtors dat)
-
-        unqual (Qual _ x) = x
-        unqual (UnQual x) = x
-
-
--- | Derive a clause of a 'traverse' like function for a constructor
-deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDecl -> WithInstances Match
-deriveTraversalCtor tt ap ctor = do
-    let nam = ctorDeclName ctor
-        arity = ctorDeclArity ctor
-    tTypes <- mapM (deriveTraversalType tt ap) (map snd $ ctorDeclFields ctor)
-    return $ traverseFunc tt (PParen $ PApp (qname nam) (vars pVar 'a' arity))
-           $ traverseCtor tt nam (zipWith App tTypes (vars var 'a' arity))
-
-
-
--- | Derive a traversal for a type
-deriveTraversalType :: TraveralType -> ArgPositions -> Type -> WithInstances Trav
-deriveTraversalType tt ap (TyParen x) = deriveTraversalType tt ap x
-deriveTraversalType tt ap TyForall{}  = fail "forall not supported in traversal deriving"
-deriveTraversalType tt ap (TyFun a b)
-                                           = fromJust (traverseArrow tt)
-                                                 <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a
-                                                 <*> deriveTraversalType tt                                     ap b
-deriveTraversalType tt ap (TyApp a b)      = deriveTraversalApp tt ap a [b] -- T a b c ...
-deriveTraversalType tt ap (TyList a)       = deriveTraversalType tt ap $ TyApp (TyCon $ Special ListCon) a
-deriveTraversalType tt ap (TyTuple b a)    = deriveTraversalType tt ap $ tyApps (TyCon $ Special $ TupleCon b $ length a) a
-deriveTraversalType tt ap (TyCon n)        = return $ traversalId tt -- T
-deriveTraversalType tt ap (TyVar (Ident n)) -- a
-  | ap n /= traversalArg tt                = return $ traversalId tt
-  | traversalCo tt                         = fail "tyvar used in covariant position"
-  | otherwise                              = return $ traversalDirect tt
-
-
--- | Find all arguments to a type application, then derive a traversal
-deriveTraversalApp :: TraveralType -> ArgPositions -> Type -> [Type] -> WithInstances Trav
-deriveTraversalApp tt ap (TyApp a b) args = deriveTraversalApp tt ap a (b : args)
-deriveTraversalApp tt ap tycon@TyTuple{} args = do -- (a,b,c)
-         tArgs <- mapM (deriveTraversalType tt ap) args
-         return $
-           if (all (== traversalId tt) tArgs) then
-             traversalId tt
-           else
-             Lambda sl [PTuple Boxed (vars pVar 't' (length args))]
-                  (traverseTuple tt $ zipWith App tArgs (vars var 't' (length args)))
-deriveTraversalApp tt ap tycon args = do -- T a b c
-         tCon  <- deriveTraversalType tt ap tycon
-         tArgs <- mapM (deriveTraversalType tt ap) args
-         -- need instances?
-         case tycon of
-           TyVar (Ident n) | ap n == traversalArg tt -> fail "kind error: type used type constructor"
-                   | otherwise               -> tell $ S.fromList
-                                                [ RequiredInstance n i
-                                                | (t,i) <- zip (reverse tArgs) [1..]
-                                                , t /= traversalId tt
-                                                ]
-           _ -> return ()
-         -- combine non-id traversals
-         let nonId = [ traverseArg tt i t
-                     | (t,i) <- zip (reverse tArgs) [1..]
-                     , t /= traversalId tt
-                     ]
-         return $ case nonId of
-           [] -> traversalId tt -- no interesting arguments to type con
-           _  -> foldl1 (traversalPlus tt) nonId
-
-
--- | Lift a traversal to the argument of a type constructor
-traverseArg :: TraveralType -> Int -> Trav -> Trav
-traverseArg tt n e   =  traversalFunc tt (traversalNameN tt n) e
-
-traversalNameN :: TraveralType -> Int -> QName
-traversalNameN tt n | n <= 1    = nm
-                    | otherwise = nm `f` (if n > 1 then show n else "")
-  where nm = traversalName tt
-        f (Qual m x) y = Qual m $ x `g` y
-        f (UnQual x) y = UnQual $ x `g` y
-        g (Ident x) y = Ident $ x ++ y
-
--- | Information on argument positions
-type ArgPositions = String -> Int
-
--- | Position of an argument in the data type
---   In the type  "data X a b c"
---   positions are: a -> 3, b -> 2, c -> 1
-argPositions :: DataDecl -> String -> Int
-argPositions dat = \nm -> case elemIndex nm args of
-    Nothing -> error "impossible: tyvar not in scope"
-    Just k  -> length args - k
- where args = dataDeclVars dat
diff --git a/Data/Derive/Is.hs b/Data/Derive/Is.hs
deleted file mode 100644
--- a/Data/Derive/Is.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module Data.Derive.Is(makeIs) where
-{-
-
-test :: Sample
-
-isFirst :: Sample a -> Bool
-isFirst (First{}) = True ; isFirst _ = False
-
-isSecond :: Sample a -> Bool
-isSecond (Second{}) = True ; isSecond _ = False
-
-isThird :: Sample a -> Bool
-isThird (Third{}) = True ; isThird _ = False
-
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-
-
-makeIs :: Derivation
-makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d
-
-
-makeIsCtor :: DataDecl -> CtorDecl -> [Decl]
-makeIsCtor d c = if not $ isIdent $ ctorDeclName c then [] else
-        [TypeSig sl [name nam] (dataDeclType d `TyFun` tyCon "Bool")
-        ,FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]
-    where
-        nam = "is" ++ ctorDeclName c
-        
-        match = Match sl (name nam) [PParen $ PRec (qname $ ctorDeclName c) []] Nothing (UnGuardedRhs $ con "True") Nothing
-        defMatch = Match sl (name nam) [PWildCard] Nothing (UnGuardedRhs $ con "False") Nothing
diff --git a/Data/Derive/JSON.hs b/Data/Derive/JSON.hs
deleted file mode 100644
--- a/Data/Derive/JSON.hs
+++ /dev/null
@@ -1,165 +0,0 @@
--- |
--- Copyright:   (c) Bertram Felgenhauer 2009
--- License:     BSD3
--- Stability:   experimental
--- Portability: portable
---
--- Derive 'Text.JSON' instances.
---
--- Unlike Text.JSON.Generics, single constructor types are /not/ handled
--- specially. Every value is encoded as an object with a single field,
--- with the constructor name as key and the values as its contents.
---
--- If the constructor is a record, the contents is an Object with the
--- field names as keys. Otherwise, the contents is an array.
-
-module Data.Derive.JSON (makeJSON) where
-
-import qualified Language.Haskell as H
-import Language.Haskell (
-    Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt,
-    (~=), var, pVar, con, strE, strP, apps, qname, sl,
-    ctorDeclFields, ctorDeclName, dataDeclCtors)
-
-{-
-import "json" Text.JSON
-import Text.JSON.Types
-
-example :: Custom
-instance JSON a => JSON (Sample a) where
-    readJSON (JSObject x)   = $(readJSON)
-    readJSON _              = Error "..."
-    showJSON (First)        = $(showJSON 0)
-    showJSON (Second x1 x2) = $(showJSON 1)
-    showJSON (Third x1)     = $(showJSON 2)
--}
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeJSON :: Derivation
-makeJSON = derivationCustomDSL "JSON" custom $
-    List [Instance ["JSON"] "JSON" (List [App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "readJSON"]),List [App "PParen" (List [App "PApp" (List [
-    App "UnQual" (List [App "Ident" (List [String "JSObject"])]),List
-    [App "PVar" (List [App "Ident" (List [String "x"])])]])])],App
-    "Nothing" (List []),App "UnGuardedRhs" (List [App "SpliceExp" (
-    List [App "ParenSplice" (List [App "Var" (List [App "UnQual" (List
-    [App "Ident" (List [String "readJSON"])])])])])]),App "Nothing" (
-    List [])]),App "Match" (List [App "Ident" (List [String "readJSON"
-    ]),List [App "PWildCard" (List [])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "App" (List [App "Con" (List [App
-    "UnQual" (List [App "Ident" (List [String "Error"])])]),App "Lit"
-    (List [App "String" (List [String "..."])])])]),App "Nothing" (
-    List [])])]])]),App "InsDecl" (List [App "FunBind" (List [MapCtor
-    (App "Match" (List [App "Ident" (List [String "showJSON"]),List [
-    App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
-    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
-    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
-    "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "showJSON"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])
-    ])])]),App "Nothing" (List [])]))])])])]
--- GENERATED STOP
-
--- ^ 'Derivation' for 'JSON'
-
-custom :: FullDataDecl -> [Decl] -> [Decl]
-custom = customSplice splice
-
-splice :: FullDataDecl -> Exp -> Exp
-splice d x | x ~= "readJSON" = mkRead d
-splice d (H.App x (H.Lit (H.Int y))) | x~= "showJSON" = mkShow d y
-splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e
-
-------------------------------------------------------------------------------
--- showJSON
-
-mkShow :: FullDataDecl -> Integer -> Exp
-mkShow d y = let
-    hasFields = any (not . null . fst) (ctorDeclFields c)
-    c = dataDeclCtors (snd d) !! fromInteger y
-    mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields
-  in
-    mkJSObject $ H.List
-        [H.Tuple H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]
-
-mkShowPlainFields :: FieldDecl -> Exp
-mkShowPlainFields fs = mkJSArray $ H.List
-    [var "showJSON" `H.App` xi | xi <- vars "x" fs]
-
-mkShowRecordFields :: FieldDecl -> Exp
-mkShowRecordFields fs = mkJSObject $ H.List
-    [ H.Tuple H.Boxed [strE fn, var "showJSON" `H.App` xi]
-    | ((fn, _), xi) <- zip fs (vars "x" fs)]
-
-------------------------------------------------------------------------------
--- readJSON
-
-mkRead :: FullDataDecl -> Exp
-mkRead (_, d) = let
-    readError = con "Error" `H.App` strE "malformed JSON for type ...: ..."
-  in
-    H.Case (var "fromJSObject" `H.App` var "x") $
-    map mkReadCtor (dataDeclCtors d) ++
-    [H.Alt H.sl H.PWildCard (H.UnGuardedRhs readError) Nothing]
-
-mkReadCtor :: CtorDecl -> Alt
-mkReadCtor c = let
-    cn = ctorDeclName c
-    fs = ctorDeclFields c
-    hasFields = any (not . null . fst) fs
-    body | hasFields = mkReadRecord cn fs
-         | otherwise = mkReadPlain cn fs
-  in
-    H.Alt sl (H.PList [H.PTuple H.Boxed [strP cn, pVar "y"]])
-         (H.UnGuardedRhs body) Nothing
-
-mkReadRecord :: String -> FieldDecl -> Exp
-mkReadRecord cn fs = H.Do $
-    [H.Generator sl (H.PApp (qname "JSObject") [pVar "z"])
-          (var "return" `H.App` var "y")] ++
-    [H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d")
-          (H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z")
-          Nothing]] ++
-    zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++
-    mkReadTrailer cn fs
-
-mkReadRecordField :: String -> Pat -> (String, Type) -> Stmt
-mkReadRecordField cn xi (fn, _) = H.Generator sl xi $
-    apps (var "maybe") [
-        var "fail" `H.App` strE (unwords ["readJSON: missing field", fn,
-                                          "while decoding a", cn]),
-        var "return",
-        apps (var "lookup") [strE fn, var "d"]]
-
-mkReadPlain :: String -> FieldDecl -> Exp
-mkReadPlain cn fs = H.Do $
-    [H.Generator sl (H.PApp (qname "JSArray") [H.PList (pVars "x" fs)])
-        (var "return" `H.App` var "y")] ++
-    mkReadTrailer cn fs
-
-mkReadTrailer :: String -> FieldDecl -> [Stmt]
-mkReadTrailer cn fs =
-    [ H.Generator sl yi (var "readJSON" `H.App` xi)
-    | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++
-    [H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)]
-
-------------------------------------------------------------------------------
--- utilites
-
-mkJSObject :: Exp -> Exp
-mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e)
-
-mkJSArray :: Exp -> Exp
-mkJSArray e = con "JSArray" `H.App` e
-
-vars :: String -> FieldDecl -> [Exp]
-vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]
-
-pVars :: String -> FieldDecl -> [Pat]
-pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
diff --git a/Data/Derive/LazySet.hs b/Data/Derive/LazySet.hs
deleted file mode 100644
--- a/Data/Derive/LazySet.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-{-|
-    A pseudo derivation.  For each field in the data type, deriving
-    @LazySet@ generates a function like a record updator, but lazy where possible.
-    This is very useful in certain situations to improve laziness
-    properties.  A setter is only lazy if that field is present in one constructor.
--}
-module Data.Derive.LazySet(makeLazySet) where
-{-
-
-test :: Computer
-
-setSpeed :: Int -> Computer -> Computer
-setSpeed v x = x{speed=v}
-
-setWeight :: Double -> Computer -> Computer
-setWeight v x = Laptop v (speed x)
-
-test :: Sample
-
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-
-
-makeLazySet :: Derivation
-makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d
-
-
-makeLazySetField :: DataDecl -> String -> [Decl]
-makeLazySetField d field = if isIdent field then [TypeSig sl [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else []
-    where
-        fun = "set" ++ title field
-        typ = t `TyFun` (dataDeclType d `TyFun` dataDeclType d)
-        (t,c):tc = [(t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field]
-
-        bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren $ App (var n) (var "x") | (n,t) <- ctorDeclFields c]
-            | otherwise = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]
diff --git a/Data/Derive/Lens.hs b/Data/Derive/Lens.hs
deleted file mode 100644
--- a/Data/Derive/Lens.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{-|
-    A pseudo derivation.  For each field in the data type, deriving
-    @Lens@ generates @lens@/FieldName/@ = lens @/fieldName/@
-    (\ x v -> v { @/fieldName/@ = x })@.
-
-    This works with the @data-lens@ package.
--}
-module Data.Derive.Lens(makeLens) where
-
-{-
-import "data-lens" Data.Lens.Common
-
-test :: Sample
-
-test :: Computer
-
-lensSpeed :: Lens Computer Int
-lensSpeed = lens speed (\x v -> v{speed = x})
-
-lensWeight :: Lens Computer Double
-lensWeight = lens weight (\x v -> v{weight = x})
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-
-
-makeLens :: Derivation
-makeLens = derivationCustom "Lens" $ \(_,d) -> Right $ concatMap (makeLensField d) $ dataDeclFields d
-
-
-makeLensField :: DataDecl -> String -> [Decl]
-makeLensField d field = if isIdent field then [TypeSig sl [name ref] typ, bind ref [] bod] else []
-    where
-        ref = "lens" ++ title field
-        typ = tyApps (tyCon "Lens") [dataDeclType d, t]
-        Just t = lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
-
-        bod = apps (var "lens")
-            [var field
-            ,Paren $ Lambda sl [pVar "x",pVar "v"] $ RecUpdate (var "v") [FieldUpdate (qname field) (var "x")]]
diff --git a/Data/Derive/Monoid.hs b/Data/Derive/Monoid.hs
deleted file mode 100644
--- a/Data/Derive/Monoid.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-|
-    Derives an instance of @Monoid@. It uses the product
-    construction of monoids. @mappend@ on two different constructors
-    is undefined.
--}
-module Data.Derive.Monoid(makeMonoid) where
-{-
-import Data.Monoid hiding (First)
-
-example :: Sample
-instance Monoid a => Monoid (Sample a) where
-    mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]
-    mappend (First) (First) = First
-    mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)
-    mappend (Third x1) (Third y1) = Third (mappend x1 y1)
-    mappend _ _ | length [First{},Second{},Third{}] > 1 = error "Monoid.mappend: Different constructors for Sample"
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeMonoid :: Derivation
-makeMonoid = derivationDSL "Monoid" dslMonoid
-
-dslMonoid =
-    List [Instance ["Monoid"] "Monoid" (List [App "InsDecl" (List [App
-    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "mempty"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var"
-    (List [App "UnQual" (List [App "Ident" (List [String "head"])])]),
-    App "List" (List [MapCtor (Application (Concat (List [List [App
-    "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])])
-    ],MapField (App "Paren" (List [Application (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [String "const"])])]),App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "mempty"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])])]
-    ))])))])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App
-    "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App
-    "Ident" (List [String "mappend"]),List [App "PParen" (List [App
-    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
-    MapField (App "PVar" (List [App "Ident" (List [Concat (List [
-    String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App
-    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
-    MapField (App "PVar" (List [App "Ident" (List [Concat (List [
-    String "y",ShowInt FieldIndex])])]))])])],App "Nothing" (List []),
-    App "UnGuardedRhs" (List [Application (Concat (List [List [App
-    "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])])
-    ],MapField (App "Paren" (List [Application (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [String "mappend"])])]),App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
-    String "x",ShowInt FieldIndex])])])]),App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [Concat (List [String "y",
-    ShowInt FieldIndex])])])])])]))]))]),App "Nothing" (List [])])),
-    List [App "Match" (List [App "Ident" (List [String "mappend"]),
-    List [App "PWildCard" (List []),App "PWildCard" (List [])],App
-    "Nothing" (List []),App "GuardedRhss" (List [List [App
-    "GuardedRhs" (List [List [App "Qualifier" (List [App "InfixApp" (
-    List [App "App" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "length"])])]),App "List" (List [MapCtor (
-    App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [
-    CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List
-    [App "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (
-    List [Int 1])])])])],App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"
-    (List [App "String" (List [Concat (List [String
-    "Monoid.mappend: Different constructors for ",DataName])])])])])]]
-    ),App "Nothing" (List [])])]])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/NFData.hs b/Data/Derive/NFData.hs
deleted file mode 100644
--- a/Data/Derive/NFData.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module Data.Derive.NFData where
-{-
-import "deepseq" Control.DeepSeq(NFData, rnf)
-
-example :: Sample
-instance NFData a => NFData (Sample a) where
-    rnf (First) = ()
-    rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
-    rnf (Third x1) = rnf x1 `seq` ()
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeNFData :: Derivation
-makeNFData = derivationDSL "NFData" dslNFData
-
-dslNFData =
-    List [Instance ["NFData"] "NFData" (List [App "InsDecl" (List [App
-    "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [
-    String "rnf"]),List [App "PParen" (List [App "PApp" (List [App
-    "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
-    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])]))])])],App "Nothing" (List []),App "UnGuardedRhs"
-    (List [Fold (App "InfixApp" (List [Head,App "QVarOp" (List [App
-    "UnQual" (List [App "Ident" (List [String "seq"])])]),Tail])) (
-    Concat (List [MapField (App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "rnf"])])]),App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [Concat (List [String
-    "x",ShowInt FieldIndex])])])])])),List [App "Con" (List [App
-    "Special" (List [App "UnitCon" (List [])])])]]))]),App "Nothing" (
-    List [])]))])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Ord.hs b/Data/Derive/Ord.hs
deleted file mode 100644
--- a/Data/Derive/Ord.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-module Data.Derive.Ord where
-{-
-import Prelude
-
-example :: Sample
-instance Ord a => Ord (Sample a) where
-    compare a b = check a b
-        where
-            check (First) (First) = EQ
-            check (Second x1 x2) (Second y1 y2) = compare x1 y1 `_then` compare x2 y2 `_then` EQ
-            check (Third x1) (Third y1) = compare x1 y1 `_then` EQ
-            check x y | length [First{},Second{},Third{}] > 1 = compare (tag x) (tag y)
-
-            -- leading _ to avoid a warning when not used
-            EQ `_then` x = x
-            x `_then` _ = x
-
-            tag (First{}) = 0 :: Int
-            tag (Second{}) = 1 :: Int
-            tag (Third{}) = 2 :: Int
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeOrd :: Derivation
-makeOrd = derivationDSL "Ord" dslOrd
-
-dslOrd =
-    List [Instance ["Ord"] "Ord" (List [App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "compare"]),List [App "PVar" (List [App "Ident" (List [
-    String "a"])]),App "PVar" (List [App "Ident" (List [String "b"])])
-    ],App "Nothing" (List []),App "UnGuardedRhs" (List [Application (
-    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "check"])])]),App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "a"])])]),App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "b"])])])])]),App "Just" (List [
-    App "BDecls" (List [List [App "FunBind" (List [Concat (List [
-    MapCtor (App "Match" (List [App "Ident" (List [String "check"]),
-    List [App "PParen" (List [App "PApp" (List [App "UnQual" (List [
-    App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
-    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
-    )]),App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
-    "Ident" (List [Concat (List [String "y",ShowInt FieldIndex])])]))]
-    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App
-    "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App
-    "Ident" (List [String "_then"])])]),Head])) (Concat (List [List [
-    App "Con" (List [App "UnQual" (List [App "Ident" (List [String
-    "EQ"])])])],Reverse (MapField (Application (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [String "compare"])])]),App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
-    String "x",ShowInt FieldIndex])])])]),App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [Concat (List [String "y",
-    ShowInt FieldIndex])])])])])))]))]),App "Nothing" (List [])])),
-    List [App "Match" (List [App "Ident" (List [String "check"]),List
-    [App "PVar" (List [App "Ident" (List [String "x"])]),App "PVar" (
-    List [App "Ident" (List [String "y"])])],App "Nothing" (List []),
-    App "GuardedRhss" (List [List [App "GuardedRhs" (List [List [App
-    "Qualifier" (List [App "InfixApp" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [
-    App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])
-    ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
-    String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])],
-    Application (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "compare"])])]),App "Paren" (List [App "App"
-    (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "tag"])])]),App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "x"])])])])]),App "Paren" (List [App "App" (
-    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    String "tag"])])]),App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "y"])])])])])])])]]),App "Nothing" (List [])
-    ])]])]),App "FunBind" (List [List [App "Match" (List [App "Ident"
-    (List [String "_then"]),List [App "PApp" (List [App "UnQual" (List
-    [App "Ident" (List [String "EQ"])]),List []]),App "PVar" (List [
-    App "Ident" (List [String "x"])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "x"])])])]),App "Nothing" (List [])]),App
-    "Match" (List [App "Ident" (List [String "_then"]),List [App
-    "PVar" (List [App "Ident" (List [String "x"])]),App "PWildCard" (
-    List [])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])])
-    ])]),App "Nothing" (List [])])]]),App "FunBind" (List [MapCtor (
-    App "Match" (List [App "Ident" (List [String "tag"]),List [App
-    "PParen" (List [App "PRec" (List [App "UnQual" (List [App "Ident"
-    (List [CtorName])]),List []])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [App "ExpTypeSig" (List [App "Lit" (List [App
-    "Int" (List [CtorIndex])]),App "TyCon" (List [App "UnQual" (List [
-    App "Ident" (List [String "Int"])])])])]),App "Nothing" (List [])]
-    ))])]])])])]])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Read.hs b/Data/Derive/Read.hs
deleted file mode 100644
--- a/Data/Derive/Read.hs
+++ /dev/null
@@ -1,199 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-{-|
-    Derives @Read@.  This is as defined by the Haskell report, except
-    there is no support for infix constructors.  If you attempt to
-    derive @Read@ for a data type with infix constructors, the
-    constructors are handled as if they were prefix constructors, using
-    the @(@/consym/@)@ syntax.
--}
-module Data.Derive.Read(makeRead) where
-
-{-
-import Prelude
-
-example :: Custom
-instance Read a => Read (Sample a) where
-    readsPrec p0 r = 
-        readParen $(bracket 0) (\r0 -> $(comp 0 First )) r ++
-        readParen $(bracket 1) (\r0 -> $(comp 1 Second)) r ++
-        readParen $(bracket 2) (\r0 -> $(comp 2 Third )) r ++
-        []
-
-test :: Sample
-instance Read a => Read (Sample a) where
-    readsPrec p0 r =
-        readParen False (\r0 ->
-            [ (First, r1)
-            | ("First", r1) <- lex r0]) r
-        ++
-        readParen (p0 > 10) (\r0 ->
-            [ (Second x1 x2, r3)
-            | ("Second", r1) <- lex r0
-            , (x1, r2) <- readsPrec 11 r1
-            , (x2, r3) <- readsPrec 11 r2]) r
-        ++
-        readParen (p0 > 10) (\r0 ->
-            [ (Third x1, r2)
-            | ("Third", r1) <- lex r0
-            , (x1, r2) <- readsPrec 11 r1]) r
-
-test :: Computer
-instance Read Computer where
-    readsPrec _ r =
-        readParen False (\r0 ->
-            [ (Laptop x1 x2, r10)
-            | ("Laptop", r1) <- lex r0
-            , ("{", r2) <- lex r1
-            , ("weight", r3) <- lex r2
-            , ("=", r4) <- lex r3
-            , (x1, r5) <- readsPrec 0 r4
-            , (",", r6) <- lex r5
-            , ("speed", r7) <- lex r6
-            , ("=", r8) <- lex r7
-            , (x2, r9) <- readsPrec 0 r8
-            , ("}", r10) <- lex r9]) r
-        ++
-        readParen False (\r0 ->
-            [ (Desktop x1, r6)
-            | ("Desktop", r1) <- lex r0
-            , ("{", r2) <- lex r1
-            , ("speed", r3) <- lex r2
-            , ("=", r4) <- lex r3
-            , (x1, r5) <- readsPrec 0 r4
-            , ("}", r6) <- lex r5]) r
-
-test :: (:*:)
-instance (Read a, Read b) => Read ((:*:) a b) where
-    readsPrec p0 r =
-        readParen (p0 > 10) (\r0 ->
-            [ ((:*:) x1 x2, r3)
-            | ("(:*:)", r1) <- lex r0
-            , (x1, r2) <- readsPrec 11 r1
-            , (x2, r3) <- readsPrec 11 r2]) r
-
--}
-import Data.Derive.DSL.HSE
-import qualified Language.Haskell as H
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeRead :: Derivation
-makeRead = derivationCustomDSL "Read" custom $
-    List [Instance ["Read"] "Read" (List [App "InsDecl" (List [App
-    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
-    String "readsPrec"]),List [App "PVar" (List [App "Ident" (List [
-    Concat (List [String "p",ShowInt (Int 0)])])]),App "PVar" (List [
-    App "Ident" (List [String "r"])])],App "Nothing" (List []),App
-    "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
-    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
-    "++"])])]),Tail])) (Concat (List [MapCtor (Application (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "readParen"])])]),App "SpliceExp" (List [App "ParenSplice" (List [
-    App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "bracket"])])]),App "Lit" (List [App "Int" (List [
-    CtorIndex])])])])]),App "Paren" (List [App "Lambda" (List [List [
-    App "PVar" (List [App "Ident" (List [Concat (List [String "r",
-    ShowInt (Int 0)])])])],App "SpliceExp" (List [App "ParenSplice" (
-    List [Application (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [String "comp"])])]),App "Lit" (List [App "Int" (
-    List [CtorIndex])]),App "Con" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])])])])])])])]),App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "r"])])])])),List [App
-    "List" (List [List []])]]))]),App "Nothing" (List [])])]])])])]
--- GENERATED STOP
-
-custom = customSplice splice
-
-getCtor d i = dataDeclCtors (snd d) !! fromIntegral i
-hasFields c = any ((/=) "" . fst) $ ctorDeclFields c
-
-splice :: FullDataDecl -> Exp -> Exp
-splice d (H.App x (H.Lit (H.Int y))) | x ~= "bracket", let c = getCtor d y =
-    if hasFields c || null (ctorDeclFields c)
-    then con "False"
-    else Paren $ InfixApp (var "p0") (QVarOp $ UnQual $ Symbol ">") (H.Lit $ H.Int 10)
-
-splice d (H.App (H.App x (H.Lit (H.Int y))) _) | x ~= "comp" =
-    if hasFields c then readFields c else readCtor c
-    where c = getCtor d y
-
-
-readCtor :: CtorDecl -> Exp
-readCtor c =
-    ListComp (Tuple Boxed [cpat, var ('r':show (cn+1))]) $
-        matchStr (ctorDeclName c) 0 :
-        [QualStmt $ Generator sl
-            (PTuple Boxed [pVar $ v 'x' 0, pVar $ v 'r' 1])
-            (apps (var "readsPrec") [H.Lit $ H.Int 11, var $ v 'r' 0])
-            | i <- [1..cn], let v c j = c : show (i+j)]
-    where
-        cn = ctorDeclArity c
-        cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn]
-
-
-readFields :: CtorDecl -> Exp
-readFields c =
-    ListComp (Tuple Boxed [cpat, var $ 'r':show ((cn*4)+2)]) $
-        matchStr (ctorDeclName c) 0 :
-        concat [
-            matchStr (r == 1 ? "{" $ ",") r :
-            matchStr fld (r+1) :
-            matchStr "=" (r+2) :
-            QualStmt (Generator sl
-                (PTuple Boxed [pVar $ 'x':show i, pVar $ 'r':show (r+4)])
-                (apps (var "readsPrec") [H.Lit $ H.Int 0, var $ 'r':show (r+3)]))
-            : []
-            | (i,r,(fld,_)) <- zip3 [1..] [1,5..] (ctorDeclFields c)
-            ] ++
-        [matchStr "}" ((cn*4)+1)]
-    where
-        cn = ctorDeclArity c
-        cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn]
-
-
-matchStr :: String -> Int -> QualStmt
-matchStr s i = QualStmt $ Generator sl (PTuple Boxed [PLit H.Signless $ H.String s, pVar $ 'r':show (i+1)]) (var "lex" `H.App` var ('r':show i))
-
-
-
-
-{-
-
-read' dat = [instance_default "Read" dat [funN "readsPrec" [sclause [vr "p0", vr "r"] body]]]
-    where
-        body = (++::) [ readit ctr | ctr <- dataCtors dat ]
-
-readit ctr = case ctorFields ctr of [] -> norm
-                                    fl -> flds fl
-    where
-        norm = lK "readParen"
-               [vr "p0" >: lit (10::Integer),
-                "r0" ->: runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'),
-                l0 "r"]
-
-        flds f = lK "readParen" 
-                 [false,
-                  "r0" ->: runComp (pName . pLex "{" .
-                                    foldr (.) id (intersperse (pLex ",")
-                                                  (zipWith pField (ctv ctr 'x') f)) .
-                                    pLex "}") (ctp ctr 'x'),
-                  l0 "r"]
-
-        runComp fn ex = CompE $ fn (\k -> [ NoBindS (tup [ex, vrn 'r' k]) ]) 0
-
-        pArse pat fun ct k = BindS (tup [pat, vrn 'r' (k+1)]) (AppE fun (vrn 'r' k)) : ct (k+1)
-
-        pLex pat = pArse (lit pat) (l0 "lex")
-
-        name = ctorName ctr
-
-        pName | isAlpha (head name) || head name == '_' = pLex name
-              | otherwise                               = pLex "(" . pLex name . pLex ")"
-
-        pRead pc pat = pArse pat (l1 "readsPrec" (lit (pc :: Integer)))
-
-        pField pat fld = pLex fld . pLex "=" . pRead 0 pat
--}
diff --git a/Data/Derive/Ref.hs b/Data/Derive/Ref.hs
deleted file mode 100644
--- a/Data/Derive/Ref.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-|
-    A pseudo derivation.  For each field in the data type, deriving
-    @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =
-    \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.
-
-    This is intended for use with the compositional functional references
-    described in
-    <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.
--}
-module Data.Derive.Ref(makeRef) where
-
-{-
-test :: Sample
-
-test :: Computer
-
-refSpeed :: Ref Computer
-refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}
-
-refWeight :: Ref Computer
-refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-
-
-makeRef :: Derivation
-makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d
-
-
-makeRefField :: DataDecl -> String -> [Decl]
-makeRefField d field = if isIdent field then [TypeSig sl [name ref] typ, bind ref [] bod] else []
-    where
-        ref = "ref" ++ title field
-        typ = TyApp (tyCon "Ref") (dataDeclType d)
-
-        bod = RecConstr (qname "Ref")
-            [FieldUpdate (qname "select") (var field)
-            ,FieldUpdate (qname "update") $ Lambda sl [pVar "f",pVar "v"] $
-                RecUpdate (var "v") [FieldUpdate (qname field) $ App (var "f") $ Paren $ App (var field) (var "v")]
-            ]
diff --git a/Data/Derive/Serial.hs b/Data/Derive/Serial.hs
deleted file mode 100644
--- a/Data/Derive/Serial.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-module Data.Derive.Serial where
-{-
-import "smallcheck" Test.SmallCheck
-
-example :: Sample
-
-instance Serial a => Serial (Sample a) where
-    series = cons0 First \/
-             cons2 Second \/
-             cons1 Third
-
-    coseries rs d = [ \t -> case t of
-                                First -> t0
-                                Second x1 x2 -> t1 x1 x2
-                                Third x1 -> t2 x1
-                    | t0 <- alts0 rs d `const` First{}
-                    , t1 <- alts2 rs d `const` Second{}
-                    , t2 <- alts1 rs d `const` Third{}
-                    ]
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeSerial :: Derivation
-makeSerial = derivationDSL "Serial" dslSerial
-
-dslSerial =
-    List [Instance ["Serial"] "Serial" (List [App "InsDecl" (List [App
-    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "series"])]),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List
-    [Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
-    String "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
-    String "cons",ShowInt CtorArity])])])]),App "Con" (List [App
-    "UnQual" (List [App "Ident" (List [CtorName])])])]))))]),App
-    "Nothing" (List [])])]),App "InsDecl" (List [App "FunBind" (List [
-    List [App "Match" (List [App "Ident" (List [String "coseries"]),
-    List [App "PVar" (List [App "Ident" (List [String "rs"])]),App
-    "PVar" (List [App "Ident" (List [String "d"])])],App "Nothing" (
-    List []),App "UnGuardedRhs" (List [App "ListComp" (List [App
-    "Lambda" (List [List [App "PVar" (List [App "Ident" (List [String
-    "t"])])],App "Case" (List [App "Var" (List [App "UnQual" (List [
-    App "Ident" (List [String "t"])])]),MapCtor (App "Alt" (List [App
-    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
-    MapField (App "PVar" (List [App "Ident" (List [Concat (List [
-    String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [
-    Application (Concat (List [List [App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [Concat (List [String "t",ShowInt
-    CtorIndex])])])])],MapField (App "Var" (List [App "UnQual" (List [
-    App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])
-    ])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt"
-    (List [App "Generator" (List [App "PVar" (List [App "Ident" (List
-    [Concat (List [String "t",ShowInt CtorIndex])])]),App "InfixApp" (
-    List [Application (List [App "Var" (List [App "UnQual" (List [App
-    "Ident" (List [Concat (List [String "alts",ShowInt CtorArity])])])
-    ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "rs"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List
-    [String "d"])])])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Ident" (List [String "const"])])]),App "RecConstr" (List [App
-    "UnQual" (List [App "Ident" (List [CtorName])]),List []])])])]))])
-    ]),App "Nothing" (List [])])]])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Serialize.hs b/Data/Derive/Serialize.hs
deleted file mode 100644
--- a/Data/Derive/Serialize.hs
+++ /dev/null
@@ -1,134 +0,0 @@
-module Data.Derive.Serialize where
-{-
-import "cereal" Data.Serialize
-
-example :: Sample
-
-instance Serialize alpha => Serialize (Sample alpha) where
-    put x = case x of
-        First          -> do putTag 0
-        Second  x1 x2  -> do putTag 1 ; put x1 ; put x2
-        Third   x1     -> do putTag 2 ; put x1
-        where
-            useTag = length [First{}, Second{}, Third{}] > 1
-            putTag x = when useTag (putWord8 x)
-
-    get = do
-        i <- getTag
-        case i of
-            0 -> do return (First)
-            1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)
-            2 -> do x1 <- get ; return (Third x1)
-            _ -> error "Corrupted binary data for Sample"
-        where
-            useTag = length [First{}, Second{}, Third{}] > 1
-            getTag = if useTag then getWord8 else return 0
-
-
-test :: List
-
-instance Serialize a => Serialize (List a) where
-    put x = case x of
-        Nil -> putWord8 0
-        Cons x1 x2 -> do putWord8 1; put x1; put x2
-
-    get = do
-        i <- getWord8
-        case i of
-            0 -> return Nil
-            1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)
-            _ -> error "Corrupted binary data for List"
-
-test :: Assoced
-
-instance Serialize typ => Serialize (Assoced typ) where
-    put (Assoced x1 x2) = do put x1; put x2
-    get = do x1 <- get; x2 <- get; return (Assoced x1 x2)
-
-
--}
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeSerialize :: Derivation
-makeSerialize = derivationDSL "Serialize" dslSerialize
-
-dslSerialize =
-    List [Instance ["Serialize"] "Serialize" (List [App "InsDecl" (
-    List [App "FunBind" (List [List [App "Match" (List [App "Ident" (
-    List [String "put"]),List [App "PVar" (List [App "Ident" (List [
-    String "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [
-    App "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List
-    [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
-    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])]))]),App "UnGuardedRhs" (List [App "Do" (List [
-    Concat (List [List [App "Qualifier" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])
-    ],MapField (App "Qualifier" (List [App "App" (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "put"])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
-    List [String "x",ShowInt FieldIndex])])])])])]))])])]),App
-    "Nothing" (List [])]))])]),App "Just" (List [App "BDecls" (List [
-    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
-    String "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List
-    [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "length"])])]),App "List" (List [MapCtor (App
-    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
-    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
-    [Int 1])])])]),App "Nothing" (List [])]),App "FunBind" (List [List
-    [App "Match" (List [App "Ident" (List [String "putTag"]),List [App
-    "PVar" (List [App "Ident" (List [String "x"])])],App "Nothing" (
-    List []),App "UnGuardedRhs" (List [Application (List [App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "when"])])]),
-    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
-    "useTag"])])]),App "Paren" (List [App "App" (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [Concat (List [String
-    "putWord",ShowInt (Int 8)])])])]),App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [String "x"])])])])])])]),App "Nothing" (
-    List [])])]])]])])])]])]),App "InsDecl" (List [App "PatBind" (List
-    [App "PVar" (List [App "Ident" (List [String "get"])]),App
-    "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List
-    [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" (
-    List [App "UnQual" (List [App "Ident" (List [String "getTag"])])])
-    ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [
-    MapCtor (App "Alt" (List [App "PLit" (List [App "Signless" (List [
-    ]),App "Int" (List [CtorIndex])]),App "UnGuardedRhs" (List [App
-    "Do" (List [Concat (List [MapField (App "Generator" (List [App
-    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])]),App "Var" (List [App "UnQual" (List [App "Ident"
-    (List [String "get"])])])])),List [App "Qualifier" (List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "return"])])]),App "Paren" (List [Application (Concat
-    (List [List [App "Con" (List [App "UnQual" (List [App "Ident" (
-    List [CtorName])])])],MapField (App "Var" (List [App "UnQual" (
-    List [App "Ident" (List [Concat (List [String "x",ShowInt
-    FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [])])),
-    List [App "Alt" (List [App "PWildCard" (List []),App
-    "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"
-    (List [App "String" (List [Concat (List [String
-    "Corrupted binary data for ",DataName])])])])]),App "Nothing" (
-    List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [List
-    [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
-    "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "length"])])]),App "List" (List [MapCtor (App
-    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
-    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
-    [Int 1])])])]),App "Nothing" (List [])]),App "PatBind" (List [App
-    "PVar" (List [App "Ident" (List [String "getTag"])]),App
-    "UnGuardedRhs" (List [App "If" (List [App "Var" (List [App
-    "UnQual" (List [App "Ident" (List [String "useTag"])])]),App "Var"
-    (List [App "UnQual" (List [App "Ident" (List [Concat (List [String
-    "getWord",ShowInt (Int 8)])])])]),App "App" (List [App "Var" (List
-    [App "UnQual" (List [App "Ident" (List [String "return"])])]),App
-    "Lit" (List [App "Int" (List [Int 0])])])])]),App "Nothing" (List
-    [])])]])])])])])]
--- GENERATED STOP
diff --git a/Data/Derive/Set.hs b/Data/Derive/Set.hs
deleted file mode 100644
--- a/Data/Derive/Set.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-|
-    A pseudo derivation.  For each field in the data type, deriving
-    @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.
-    This derivation is intended to work around the fact that in Haskell
-    assigning to a field is not a first class object (although
-    extracting from a field is).
--}
-module Data.Derive.Set(makeSet) where
-
-{-
-
-test :: Computer
-
-setSpeed :: Int -> Computer -> Computer
-setSpeed v x = x{speed=v}
-
-setWeight :: Double -> Computer -> Computer
-setWeight v x = x{weight=v}
-
-test :: Sample
-
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-import Data.Maybe
-
-
-makeSet :: Derivation
-makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d
-
-
-makeSetField :: DataDecl -> String -> [Decl]
-makeSetField d field = [TypeSig sl [name set] typ, bind set [pVar "v",pVar "x"] bod]
-    where
-        set = "set" ++ title field
-        typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d)
-        typField = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
-
-        bod = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]
diff --git a/Data/Derive/Show.hs b/Data/Derive/Show.hs
deleted file mode 100644
--- a/Data/Derive/Show.hs
+++ /dev/null
@@ -1,90 +0,0 @@
-
--- | Derives @Show@.  This is as defined by the Haskell report, except
--- there is no support for infix constructors.  If you attempt to
--- derive @Show@ for a data type with infix constructors, the
--- constructors are handled as if they were prefix constructors, using
--- the @(@/consym/@)@ syntax.
-module Data.Derive.Show(makeShow) where
-
-{-
-import Prelude
-
-example :: Custom
-instance Show a => Show (Sample a) where
-    showsPrec p (First) = $(show 0)
-    showsPrec p (Second x1 x2) = $(show 1)
-    showsPrec p (Third x1) = $(show 2)
-
-
-test :: Sample
-instance Show a => Show (Sample a) where
-    showsPrec _ First = showString "First"
-    showsPrec p (Second x1 x2) = showParen (p > 10) $ showString "Second " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
-    showsPrec p (Third x1) = showParen (p > 10) $ showString "Third " . showsPrec 11 x1
-
-test :: Computer
-instance Show Computer where
-    showsPrec _ (Laptop x1 x2) =
-        showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'
-    showsPrec _ (Desktop x1) =
-        showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}'
-
-test :: (:*:)
-instance (Show a, Show b) => Show ((:*:) a b) where
-    showsPrec p ((:*:) x1 x2) = showParen (p > 10) $ showString "(:*:) " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
--}
-
-import Data.List
-import Data.Derive.DSL.HSE
-import qualified Language.Haskell as H
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeShow :: Derivation
-makeShow = derivationCustomDSL "Show" custom $
-    List [Instance ["Show"] "Show" (List [App "InsDecl" (List [App
-    "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [
-    String "showsPrec"]),List [App "PVar" (List [App "Ident" (List [
-    String "p"])]),App "PParen" (List [App "PApp" (List [App "UnQual"
-    (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List
-    [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]
-    )]))])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
-    "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "show"]
-    )])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])])]),App
-    "Nothing" (List [])]))])])])]
--- GENERATED STOP
-
--- Left is a literal string, Right is a variable
-
-custom = customSplice splice
-
-splice :: FullDataDecl -> Exp -> Exp
-splice d (H.App x (H.Lit (H.Int y))) | x ~= "show" = combine $ compress $
-        if fields then customFields c else customPlain c
-    where
-        fields = any (not . null . fst) (ctorDeclFields c)
-        c = dataDeclCtors (snd d) !! fromInteger y
-
-        out (Left [x]) = H.App (var "showChar") (H.Lit $ H.Char x)
-        out (Left xs ) = H.App (var "showString") (H.Lit $ H.String xs)
-        out (Right x) = apps (var "showsPrec") [H.Lit $ H.Int (fields ? 0 $ 11), var $ 'x' : show x]
-
-        compress (Left x:Left y:z) = compress $ Left (x++y) : z
-        compress (x:y) = x : compress y
-        compress [] = []
-
-        paren = InfixApp (H.App (var "showParen") (Paren $ InfixApp (var "p") (qvop ">") (H.Lit $ H.Int 10))) (qvop "$")
-        combine xs = (fields || or [' ' `notElem` x | Left x <- xs] ? id $ paren) $
-                     foldr1 (\x y -> InfixApp x (qvop ".") y) $ map out xs
-
-
-customPlain :: CtorDecl -> [Either String Int]
-customPlain c = intersperse (Left " ") $ Left (ctorDeclName c) : map Right [1..length (ctorDeclFields c)]
-
-customFields :: CtorDecl -> [Either String Int]
-customFields c = Left (ctorDeclName c ++ " {") : concat (intersperse [Left ", "] xs) ++ [Left "}"]
-    where xs = [[Left (n ++ " = "), Right i] | (i,(n,t)) <- zip [1..] $ ctorDeclFields c]
diff --git a/Data/Derive/Traversable.hs b/Data/Derive/Traversable.hs
deleted file mode 100644
--- a/Data/Derive/Traversable.hs
+++ /dev/null
@@ -1,56 +0,0 @@
-{-
-    This module is not written/maintained by the usual Data.Derive author.
-
-    MAINTAINER: Twan van Laarhoven 
-    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
-
-    Please send all patches to this module to Neil (ndmitchell -at- gmail),
-    and CC Twan.
--}
-
--- NOTE: Cannot be guessed as it relies on type information
-
-module Data.Derive.Traversable(makeTraversable, makeTraversableN) where
-
-{-
-import Data.Traversable
-import Control.Applicative(pure, (<*>))
-
-instance Traversable (FailList t1) where
-    traverse _f (Zoro) = pure Nil
-    traverse _f (Fial a1) = pure (Fial a1)
-    traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2
-
-instance Traversable Sample where
-    traverse _f (First) = pure First
-    traverse _f (Second a1 a2) = (Second <$> _f a1) <*> _f a2
-    traverse _f (Third a1) = Third <$> _f a1
-
-instance Traversable (Either t1) where
-    traverse _f (Left a1) = pure (Left a1)
-    traverse _f (Right a1) = Right <$> _f a1
--}
-
-import Data.Derive.Internal.Traversal
-import Data.Derive.Internal.Derivation
-import Language.Haskell
-
-
-makeTraversable :: Derivation
-makeTraversable = makeTraversableN 1
-
-makeTraversableN :: Int -> Derivation
-makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable"
-
-traverseTraversal = defaultTraversalType
-        { traversalName  = qname "traverse"
-        , traversalId    = var "pure"
-        , traversalPlus  = fail "variable used in multiple positions in a data type"
-        , traverseTuple  = \args -> liftAN (Con $ Special $ TupleCon Unboxed $ length args) args
-        , traverseCtor   = \ctor -> liftAN (con ctor)
-        , traverseFunc   = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) Nothing
-        }
-
-liftAN :: Exp -> [Exp] -> Exp
-liftAN base args = foldl (<*>) (appP (var "pure") base) args
-    where x <*> y = InfixApp (paren x) (QVarOp $ UnQual $ Symbol "<*>") (paren y)
diff --git a/Data/Derive/Typeable.hs b/Data/Derive/Typeable.hs
deleted file mode 100644
--- a/Data/Derive/Typeable.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-{-|
-    Derivation for the 'Typeable' class, as described in the Scrap
-    Your Boilerplate papers.  This derivation generates instances for
-    all kinds of TypeableK classes; as such we do NOT require the
-    GHC-specific generic downkinding instances to provide lower kind
-    instances.
-
-    Also creates a @typename_\<the type name\>@ value to hold the
-    'TypeRep'.
--}
-module Data.Derive.Typeable(makeTypeable) where
-{-
-import Data.Typeable
-
-test :: Bool
-typename_Bool :: TyCon
-typename_Bool = mkTyCon3 "package" "Example" "Bool"
-instance Typeable Bool where
-    typeOf _ = mkTyConApp typename_Bool []
-
-test :: Sample
-typename_Sample :: TyCon
-typename_Sample = mkTyCon3 "package" "Example" "Sample"
-instance Typeable1 Sample where
-    typeOf1 _ = mkTyConApp typename_Sample []
-instance Typeable a => Typeable (Sample a) where
-    typeOf = typeOfDefault
-
-test :: Either
-typename_Either :: TyCon
-typename_Either = mkTyCon3 "package" "Example" "Either"
-instance Typeable2 Either where
-    typeOf2 _ = mkTyConApp typename_Either []
-instance Typeable a => Typeable1 (Either a) where
-    typeOf1 = typeOf1Default
-instance (Typeable a, Typeable b) => Typeable (Either a b) where
-    typeOf = typeOfDefault
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-import Data.List
-
--- based on the macros in: http://darcs.haskell.org/packages/base/include/Typeable.h
-
-{-
-#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \
-instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }
-
-#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \
-instance Typeable a => Typeable1 (tycon a) where { \
-  typeOf1 = typeOf1Default }; \
-instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
-  typeOf = typeOfDefault }
-
-#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
-tcname = mkTyCon str; \
-instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \
-instance Typeable a => Typeable2 (tycon a) where { \
-  typeOf2 = typeOf2Default }; \
-instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \
-  typeOf1 = typeOf1Default }; \
-instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \
-  typeOf = typeOfDefault }
--}
-
-
-makeTypeable :: Derivation
-makeTypeable = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x
-
-
-mkTypeable :: String -> DataDecl -> [Decl]
-mkTypeable modu d =
-    [TypeSig sl [name fun] (tyCon "TyCon")] ++
-    [PatBind sl (pVar fun) (UnGuardedRhs bod) Nothing |
-        let bod = apps (var "mkTyCon3") [Lit $ String "package", Lit $ String modu, Lit $ String nam]] ++
-    [inst [] (showN n) [tyCon nam] [PWildCard] $ apps (var "mkTyConApp") [var fun, List []]] ++
-    [inst [ClassA (qname "Typeable") [v] | v <- tvs] i [TyParen $ tyApp (tyCon nam) tvs] [] $ var $ "typeOf" ++ i ++ "Default"
-        | (vs,i) <- zip (tail $ inits $ dataDeclVars d) $ map showN [n-1,n-2..]
-        , let tvs = map tyVar vs]
-    where
-        nam = dataDeclName d
-        fun = "typename_" ++ nam
-        n = length $ dataDeclVars d
-
-
-inst ctxt n typ pat expr =
-    InstDecl sl Nothing [] ctxt (qname $ "Typeable" ++ n) typ
-        [InsDecl $ bind ("typeOf" ++ n) pat expr]
-
-showN 0 = ""
-showN n = show n
diff --git a/Data/Derive/UniplateDirect.hs b/Data/Derive/UniplateDirect.hs
deleted file mode 100644
--- a/Data/Derive/UniplateDirect.hs
+++ /dev/null
@@ -1,220 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
--- NOTE: Cannot be guessed as it relies on type information
-
--- | Derive Uniplate and Biplate using the Direct combinators.
---   You must request monomorphic instances, i.e:
---
--- > data Foo a = Foo a (Bool, a)
--- >
--- > {-!
--- > deriving instance UniplateDirect (Foo Int)
--- > deriving instance UniplateDirect (Bool, Int) Int
--- > deriving instance UniplateDirect (Foo Int) Int
--- > !-}
---
---   This will generate the instances @Uniplate (Foo Int)@,
---   @Biplate (Bool, Int) Int@ and @Biplate (Foo Int) Int@.
---   Generally, start with the instance you are after (e.g. @UniplateDirect (Foo Int)@),
---   try to compile and add further instances as necessary. @UniplateDirect@ with
---   one argument derives Uniplate, and with two arguments derives Biplate.
---
---   @deriving UniplateDirect@ on a data type with no arguments derives Uniplate
---   with all type parameters defaulting to @()@.
-module Data.Derive.UniplateDirect(makeUniplateDirect) where
-
-
-{-
-import "uniplate" Data.Generics.Uniplate.Direct
-
-
--- test tuples
-test :: UniplateDirect ((), Maybe ()) ()
-instance Biplate ((), Maybe ()) () where
-    {-# INLINE biplate #-}
-    biplate (x1, x2) = plate (,) |* x1 |+ x2
-
-test :: UniplateDirect (Sample Int)
-instance Uniplate (Sample Int) where
-    {-# INLINE uniplate #-}
-    uniplate x = plate x
-
-test :: UniplateDirect (Sample Int) Int
-instance Biplate (Sample Int) Int where
-    {-# INLINE biplate #-}
-    biplate (Second x1 x2) = plate Second |* x1 |* x2
-    biplate (Third x1) = plate Third |* x1
-    biplate x = plate x
-
-test :: UniplateDirect Computer
-instance Uniplate Computer where
-    {-# INLINE uniplate #-}
-    uniplate x = plate x
-
-test :: UniplateDirect Computer Computer
-instance Biplate Computer Computer where
-    {-# INLINE biplate #-}
-    biplate = plateSelf
-
-test :: UniplateDirect Computer Double
-instance Biplate Computer Double where
-    {-# INLINE biplate #-}
-    biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2
-    biplate x = plate x
-
-test :: UniplateDirect (Assoced (Maybe Bool)) Char
-instance Biplate (Assoced (Maybe Bool)) Char where
-    {-# INLINE biplate #-}
-    biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2
-
--- test following external declarations
-test :: UniplateDirect (Either Bool Computer) Int
-instance Biplate (Either Bool Computer) Int where
-    {-# INLINE biplate #-}
-    biplate (Right x1) = plate Right |+ x1
-    biplate x = plate x
-
--- test recursive bits
-test :: UniplateDirect (List Int) Bool
-instance Biplate (List Int) Bool where
-    {-# INLINE biplate #-}
-    biplate x = plate x
--}
-
-import Language.Haskell
-import Data.Generics.Uniplate.DataOnly
-import Data.Derive.Internal.Derivation
-import Data.Maybe
-import qualified Data.Map as Map
-import Control.Arrow
-import Control.Monad.Trans.State
-
-
-makeUniplateDirect :: Derivation
-makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $
-    let known = map (declName &&& id) knownCtors
-        grab2 x = fromMaybe (grab x) $ lookup x known
-    in case args of
-        _ | not $ null [() | TyVar _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"
-        [] -> make True grab2 x x
-            where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon $ Special UnitCon
-        [x] -> make True grab2 x x
-        [x,y] -> make False grab2 x y
-        _ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)
-        
-
-make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl]
-make uni grab from to = Right [InstDecl sl Nothing [] [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni])
-        [InsDecl $ InlineSig sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]]
-    where
-        ty = grab $ tyRoot from
-        match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) Nothing
-        ms = if uni || from /= to
-             then FunBind $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (var "plate" `App` var "x") | any isNothing bods]
-             else PatBind sl (pVar "biplate") (UnGuardedRhs $ var "plateSelf") Nothing
-        bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty
-
-
-make1 :: (String -> DataDecl) -> (String,[Type]) -> S (Maybe (Pat, Exp))
-make1 grab (name,tys) = do
-    ops <- mapM (fmap show . operator grab) tys
-    let vars = ['x':show i | i <- [1..length tys]]
-        pat = PParen $ PApp (qname name) $ map pVar vars
-        (good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars
-        bod = foldl (\x (y,z) -> InfixApp x (QVarOp $ UnQual $ Symbol y) z) (App (var "plate") $ paren $ apps (con name) (map snd good)) bad
-    return $ if all (== "|-") ops then Nothing else Just (pat,bod)
-
-
-data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq
-
-instance Show Ans where
-    show Hit = "|*"
-    show Miss = "|-"
-    show Try = "|+"
-    show ListHit = "||*"
-    show ListTry = "||+"
-
-ansList Hit = ListHit
-ansList Miss = Miss
-ansList _ = ListTry
-
-
-ansJoin (Miss:xs) = ansJoin xs
-ansJoin [] = Miss
-ansJoin _ = Try
-
-
-type S a = State (Map.Map Type Ans) a
-
-run :: Type -> S a -> a
-run to act = evalState act (Map.singleton to Hit)
-
-operator :: (String -> DataDecl) -> Type -> S Ans
-operator grab from = do
-    mp <- get
-    case Map.lookup from mp of
-        Just y -> return y
-        Nothing -> do
-            fix Miss
-    where
-        fix ans = do
-            s <- get
-            modify $ Map.insert from ans
-            ans2 <- operator2 grab from
-            if ans == ans2
-                then return ans
-                else put s >> fix ans2
-
-
-operator2 :: (String -> DataDecl) -> Type -> S Ans
-operator2 grab from
-    | isTyFun from = return Try
-    | Just from2 <- fromTyList from = fmap ansList $ operator grab from2
-    | otherwise = case subst from $ grab $ tyRoot from of
-        Left from2 -> operator grab from2
-        Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs
-
-
-subst :: Type -> Decl -> Either Type [(String,[Type])]
-subst ty x@TypeDecl{} = Left $ substType ty x
-subst ty x = Right $ substData ty x
-
-substData :: Type -> Decl -> [(String,[Type])]
-substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]
-    where
-        rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)
-        f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
-        f x = x
-
-substType :: Type -> Decl -> Type
-substType ty (TypeDecl _ _ vars d) = fromTyParens $ transform f d
-    where
-        rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)
-        f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
-        f x = x
-
-
-knownCtors :: [Decl]
-knownCtors = map (fromParseResult . parseDecl)
-    ["data Int = Int"
-    ,"data Bool = Bool"
-    ,"data Char = Char"
-    ,"data Double = Double"
-    ,"data Float = Float"
-    ,"data Integer = Integer"
-    ,"data Maybe a = Nothing | Just a"
-    ,"data Either a b = Left a | Right b"
-    ,"type Rational = Ratio Integer"
-    ,"data (Integral a) => Ratio a = !a :% !a"
-    ,"type String = [Char]"
-    ] ++
-    listCtor :
-    map tupleDefn (0:[2..32])
-
-listCtor = DataDecl sl  DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
-    [QualConDecl sl [] [] $ ConDecl (Ident "[]") []
-    ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [tyVar "a", TyList $ tyVar "a"]] []
-
-tupleDefn :: Int -> Decl
-tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map tyVar vars)] []
-    where s = "(" ++ replicate (n - 1) ',' ++ ")"
-          vars = ['v':show i | i <- [1..n]]
diff --git a/Data/Derive/UniplateTypeable.hs b/Data/Derive/UniplateTypeable.hs
deleted file mode 100644
--- a/Data/Derive/UniplateTypeable.hs
+++ /dev/null
@@ -1,73 +0,0 @@
-module Data.Derive.UniplateTypeable where
-{-
-import "uniplate" Data.Generics.Uniplate.Typeable
-
-example :: Custom
-
-instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where
-    plateAll (First) = plate First
-    plateAll (Second x1 x2)  = plate Second |+ x1 |+ x2
-    plateAll (Third x1) = plate Third |+ x1
-
-test :: Bool
-
-instance (Typeable to, Uniplate to) => PlateAll Bool to where
-    plateAll False = plate False
-    plateAll True = plate True
-
-test :: Either a b
-
-instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where
-    plateAll (Left x1) = plate Left |+ x1
-    plateAll (Right x1) = plate Right |+ x1
-
--}
-
-import Data.Derive.DSL.HSE
-
--- GENERATED START
-
-import Data.Derive.DSL.DSL
-import Data.Derive.Internal.Derivation
-
-makeUniplateTypeable :: Derivation
-makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $
-    List [App "InstDecl" (List [App "Nothing" (List []),List [],List [
-    App "ClassA" (List [App "UnQual" (List [App "Ident" (List [String
-    "Typeable"])]),List [App "TyVar" (List [App "Ident" (List [String
-    "a"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" (
-    List [String "PlateAll"])]),List [App "TyVar" (List [App "Ident" (
-    List [String "a"])]),App "TyVar" (List [App "Ident" (List [String
-    "to"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" (
-    List [String "Uniplate"])]),List [App "TyVar" (List [App "Ident" (
-    List [String "to"])])]]),App "ClassA" (List [App "UnQual" (List [
-    App "Ident" (List [String "Typeable"])]),List [App "TyVar" (List [
-    App "Ident" (List [String "to"])])]])],App "UnQual" (List [App
-    "Ident" (List [String "PlateAll"])]),List [App "TyParen" (List [
-    App "TyApp" (List [App "TyCon" (List [App "UnQual" (List [App
-    "Ident" (List [DataName])])]),App "TyVar" (List [App "Ident" (List
-    [String "a"])])])]),App "TyVar" (List [App "Ident" (List [String
-    "to"])])],List [App "InsDecl" (List [App "FunBind" (List [MapCtor
-    (App "Match" (List [App "Ident" (List [String "plateAll"]),List [
-    App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
-    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
-    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
-    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App
-    "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App
-    "Symbol" (List [String "|+"])])]),Head])) (Concat (List [Reverse (
-    MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [
-    Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App
-    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
-    List [String "plate"])])]),App "Con" (List [App "UnQual" (List [
-    App "Ident" (List [CtorName])])])])]]))]),App "Nothing" (List [])]
-    ))])])]])]
--- GENERATED STOP
-
-
-custom (_,d) [InstDecl x1 x2 x3 _ x5 _ x7] = [InstDecl x1 x2 x3 x4 x5 x6 x7]
-    where
-        vars = dataDeclVars d
-        dd = (if null vars then id else TyParen) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)
-        x4 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]
-        x6 = [dd, tyVar "to"]
-        f v = [ClassA (qname "Typeable") [tyVar v], ClassA (qname "PlateAll") [tyVar v, tyVar "to"]]
diff --git a/Data/Derive/Update.hs b/Data/Derive/Update.hs
deleted file mode 100644
--- a/Data/Derive/Update.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-|
-    A Pseudo derivation. For every label, creates a function
-    foo_u and foo_s which updates and sets the label respectively,
-    e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'
--}
-module Data.Derive.Update(makeUpdate) where
-
-{-
-
-test :: Computer
-
-speed_u :: (Int -> Int) -> Computer -> Computer
-speed_u f x = x{speed = f (speed x)}
-
-speed_s :: Int -> Computer -> Computer
-speed_s v x = x{speed = v}
-
-weight_u :: (Double -> Double) -> Computer -> Computer
-weight_u f x = x{weight = f (weight x)}
-
-weight_s :: Double -> Computer -> Computer
-weight_s v x = x{weight = v}
-
-test :: Sample
-
--}
-
-import Language.Haskell
-import Data.Derive.Internal.Derivation
-import Data.Maybe
-
-
-makeUpdate :: Derivation
-makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d
-
-
-makeUpdateField :: DataDecl -> String -> [Decl]
-makeUpdateField d field =
-        [TypeSig sl [name upd] (TyParen (TyFun typF typF) `TyFun` typR)
-        ,bind upd [pVar "f",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (App (var "f") (Paren $ App (var field) (var "x")))]
-        ,TypeSig sl [name set] (typF `TyFun` typR)
-        ,bind set [pVar "v",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]]
-    where
-        set = field ++ "_s"
-        upd = field ++ "_u"
-        typR = dataDeclType d `TyFun` dataDeclType d
-        typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
diff --git a/Data/DeriveDSL.hs b/Data/DeriveDSL.hs
deleted file mode 100644
--- a/Data/DeriveDSL.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-
-module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where
-
-import Data.Derive.DSL.Derive
-import Data.Derive.DSL.Apply
-import Data.Derive.DSL.DSL
-import Data.Derive.DSL.HSE
-import Data.Derive.DSL.SYB
-import Data.Maybe
-
-
-deriveDSL :: [Decl] -> Maybe DSL
-deriveDSL = listToMaybe . derive
-
-
-applyDSL :: DSL -> DataDecl -> Either String [Decl]
-applyDSL dsl inp = Right $ apply dsl $ toInput inp
-
-
-dynamicDSL :: DSL -> Maybe [Decl]
-dynamicDSL = dslSYB
diff --git a/Data/DeriveMain.hs b/Data/DeriveMain.hs
deleted file mode 100644
--- a/Data/DeriveMain.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Needed for Haddock docs
-
--- | Use this module to create your own derive program, supporting custom derivations.
---   As an example:
---
--- @
---   import "Data.DeriveMain"        ('deriveMain')
---   import "Data.Derive.All"        ('derivations')
---   import MyProject.MyDerivation (myDerivation)
--- @
---
--- @
---   main :: IO
---   main = 'deriveMain' $ [myDerivation] ++ 'derivations'
--- @
-module Data.DeriveMain(deriveMain) where
-
-import Derive.Main
-import Data.Derive.All(derivations)
diff --git a/Data/DeriveTH.hs b/Data/DeriveTH.hs
deleted file mode 100644
--- a/Data/DeriveTH.hs
+++ /dev/null
@@ -1,44 +0,0 @@
--- | The main TH driver module.  It is intended that this need be the
--- only module imported by user code; it takes care of all data
--- threading issues such that all one needs to do is:
---
--- @
---   data Foo = Foo ; $( derive makeEq ''Foo )
--- @
-module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where
-
-import Control.Monad
-
-import Data.Derive.All
-import Data.Derive.Internal.Derivation
-import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)
-import Language.Haskell as HS
-import Language.Haskell.Convert
-
-
--- | Derive an instance of some class. @derive@ only derives instances
--- for the type of the argument.
-derive :: Derivation -> TH.Name -> Q [Dec]
-derive d name = do
-    x <- reify name
-    case x of
-        TyConI dec -> deriveFromDec d dec
-        _ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x
-
-
-derives :: [Derivation] -> [TH.Name] -> Q [Dec]
-derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]
-
-
--- | Derive an instance of some class. @deriveFromDec@ only derives instances
--- for the type of the argument.
-deriveFromDec :: Derivation -> Dec -> Q [Dec]
-deriveFromDec d x = do
-    x <- liftM normData $ expandData x
-    let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x
-    case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of
-        Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []
-        Right v -> return $ convert v
-
-toFullDataDecl :: Dec -> FullDataDecl
-toFullDataDecl x = (ModuleName "Todo", convert x)
diff --git a/Derive/Derivation.hs b/Derive/Derivation.hs
deleted file mode 100644
--- a/Derive/Derivation.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-
-module Derive.Derivation(wantDerive, performDerive, writeDerive) where
-
-import System.IO
-import System.IO.Unsafe
-import Language.Haskell
-import Control.Arrow
-import Control.Monad
-import Data.List
-import Derive.Utils
-import Derive.Flags
-import Data.Derive.Internal.Derivation
-import qualified Data.Map as Map
-
-
----------------------------------------------------------------------
--- WHAT DO YOU WANT TO DERIVE
-
-wantDerive :: [Flag] -> Module -> Module -> [Type]
-wantDerive flag real mine = nub $ map fromTyParens $ wantDeriveFlag flag decls ++ wantDeriveAnnotation real mine
-    where decls = filter isDataDecl $ moduleDecls mine
-
-
-wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type]
-wantDeriveFlag flags decls = [TyApp (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]
-    where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]
-
-wantDeriveAnnotation :: Module -> Module -> [Type]
-wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real
-
-
-moduleDerives :: Module -> [Type]
-moduleDerives = concatMap f . moduleDecls 
-    where
-        f (DataDecl _ _ _ name vars _ deriv) = g name vars deriv
-        f (GDataDecl _ _ _ name vars _ _ deriv) = g name vars deriv
-        f (DerivDecl _ _ _ _ name args) = [TyCon name `tyApps` args]
-        f _ = []
-
-        g name vars deriv = [TyCon a `tyApps` (b:bs) | (a,bs) <- deriv]
-            where b = TyCon (UnQual name) `tyApps` map (tyVar . prettyPrint) vars
-
-
----------------------------------------------------------------------
--- ACTUALLY DERIVE IT
-
-performDerive :: [Derivation] -> Module -> [Type] -> [String]
-performDerive derivations modu = concatMap ((:) "" . f)
-    where
-        grab = getDecl modu
-
-        g = getDerivation derivations
-        f ty = case d ty grab (moduleName modu, grab typ1Name) of
-                Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]
-                Right x -> concatMap (lines . prettyPrint) x
-            where
-                d = derivationOp $ g clsName
-                (cls,typ1:_) = fromTyApps ty
-                clsName = prettyPrint cls
-                typ1Name = tyRoot typ1
-                msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x
-
-
-getDecl :: Module -> (String -> Decl)
-getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp
-    where
-        mp = Map.fromList $ concatMap f $ moduleDecls modu
-        f x@(DataDecl _ _ _ name _ _ _) = [(prettyPrint name, x)]
-        f x@(GDataDecl _ _ _ name _ _ _ _) = [(prettyPrint name, x)]
-        f x@(TypeDecl _ name _ _) = [(prettyPrint name, x)]
-        f _ = []
-
-
-getDerivation :: [Derivation] -> String -> Derivation
-getDerivation derivations = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp
-    where
-        mp = Map.fromList $ map (derivationName &&& id) derivations
-
-
----------------------------------------------------------------------
--- WRITE IT BACK
-
-writeDerive :: FilePath -> ModuleName -> [Flag] -> [String] -> IO ()
-writeDerive file modu flags xs = do
-    -- force the output first, ensure that we don't crash half way through
-    () <- length (concat xs) `seq` return ()
-    
-    let append = Append `elem` flags
-    let output = [x | Output x <- flags]
-
-    let ans = take 1 ["module " ++ x ++ " where" | Modu x <- reverse flags] ++
-              ["import " ++ if null i then prettyPrint modu else i | Import i <- flags] ++
-              xs
-
-    when append $ do
-        src <- readFile' file
-        writeGenerated file ans
-
-    forM output $ \o -> writeFile o $ unlines ans
-    when (not append && null output) $ putStr $ unlines ans
diff --git a/Derive/Flags.hs b/Derive/Flags.hs
deleted file mode 100644
--- a/Derive/Flags.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-
-module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where
-
-import System.Environment
-import System.Console.GetOpt
-import System.Directory
-import Language.Haskell
-import System.Exit
-import System.IO
-import Data.Maybe
-
-
-data Flag = Version | Help | Output String | Import String | Modu String
-          | Append | Derive [String] | NoOpts | Preprocessor | Test | Generate
-            deriving (Eq, Show)
-
-
-options :: [OptDescr Flag]
-options =
-    [Option "v"  ["version"]  (NoArg Version)          "show version number"
-    ,Option "h?" ["help"]     (NoArg Help)             "show help message"
-    ,Option "o"  ["output"]   (ReqArg Output "FILE")   "output FILE"
-    ,Option "i"  ["import"]   (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"
-    ,Option "m"  ["module"]   (ReqArg Modu "MODULE")   "add a module MODULE where statement"
-    ,Option "a"  ["append"]   (NoArg Append)           "append the result to the file"
-    ,Option "d"  ["derive"]   (ReqArg splt "DERIVES")  "things to derive for all types"
-    ,Option "n"  ["no-opts"]  (NoArg NoOpts)           "ignore the file options"
-    ,Option "F"  ["preprocessor"] (NoArg Preprocessor) "operate as a GHC preprocessor with -pgmF"
-    ,Option ""   ["test"]     (NoArg Test)             "run the test suite"
-    ,Option ""   ["generate"] (NoArg Generate)         "perform code generation"
-    ]
-    where splt = Derive . words . map (\x -> if x == ',' then ' ' else x)
-
-
-flagInfo = usageInfo "Usage: derive [OPTION...] files..." options
-
-
-getFlags :: IO ([Flag], [String])
-getFlags = do
-    args <- getArgs
-    case getOpt Permute options args of
-        (o,n,[]  ) | Version `elem` o -> putStrLn "Derive 2.5.* (C) Neil Mitchell 2006-2013" >> exitSuccess
-                   | Help `elem` o    -> putStr flagInfo >> exitSuccess
-                   | Preprocessor `elem` o -> return (o,n)
-                   | otherwise        -> do files <- mapM pickFile n; return (o, files)
-        (_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure
-    where
-        exitSuccess = exitWith ExitSuccess
-
-
-pickFile :: FilePath -> IO FilePath
-pickFile orig = f [orig, orig ++ ".hs", orig ++ ".lhs"]
-    where
-        f [] = error $ "File not found: " ++ orig
-        f (x:xs) = do
-            b <- doesFileExist x
-            if b then return x else f xs
-
-
-addFlags :: [Flag] -> (SrcLoc, [String]) -> [Flag]
-addFlags flags (sl,xs)
-    | NoOpts `elem` flags = flags
-    | errs /= [] = error $ prettyPrint sl ++ "\n" ++ concat errs
-    | otherwise = flags ++ a
-    where (a,_,errs) = getOpt Permute options xs
diff --git a/Derive/Generate.hs b/Derive/Generate.hs
deleted file mode 100644
--- a/Derive/Generate.hs
+++ /dev/null
@@ -1,115 +0,0 @@
-
-module Derive.Generate(generate) where
-
-import Language.Haskell.Exts
-import Data.DeriveDSL
-import Derive.Utils
-import Control.Monad
-import Data.Maybe
-import System.FilePath
-import System.Directory
-import Data.Char
-import Data.List
-
-
-evil = words "TTypeable Uniplate"
-
--- generate extra information for each derivation
-generate :: IO ()
-generate = do
-    xs <- getDirectoryContents "Data/Derive"
-    xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
-    lis <- mapM generateFile $ map ("Data/Derive" </>) xs
-    let names = map dropExtension xs
-        n = maximum $ map length names
-    writeGenerated "Data/Derive/All.hs" $
-        ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++
-        ["derivations :: [Derivation]"
-        ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]
-    writeGenerated "README.md" $ ["-->",""] ++ lis ++ ["","<!--"]
-    writeGenerated "derive.cabal" $ map ("        Data.Derive."++) names
-
-
--- return the Documentation string
-generateFile :: FilePath -> IO String
-generateFile file = do
-    let name = takeBaseName file
-    putStrLn $ "Generating " ++ name
-    src <- readSrc file
-    when (isJust $ srcExample src) $ do
-        let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $
-                            deriveDSL $ fromJust $ srcExample src
-        writeGenerated file $
-            [""
-            ,"import Data.Derive.DSL.DSL"
-            ,"import Data.Derive.Internal.Derivation"
-            ,""
-            ,"make" ++ name ++ " :: Derivation"
-            ] ++ (if srcCustom src then
-                ["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]
-            else
-                ["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name
-                ,""
-                ,"dsl" ++ name ++ " ="
-            ]) ++
-            map (replicate 4 ' ' ++) (wrap 66 $ show dsl)
-
-
-        let inst = dynamicDSL dsl
-            instFile = takeDirectory file </> "Instance" </> name <.> "hs"
-        b <- doesFileExist instFile
-        if not (srcCustom src) && isJust inst then do
-            writeGenerated instFile $
-                ["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] ++
-                ["","module Data.Derive.Instance." ++ name ++ " where",""] ++
-                (map prettyPrint $ srcImportStd src) ++
-                ["import Data.Derive.Internal.Instance",""] ++
-                (map prettyPrint $ fromJust inst) ++ [""]
-         else when b $
-            error $ "Previously generated dynamic instance can not be regenerated, " ++ name
-
-    let imp = listToMaybe $ srcImport src
-    return $
-        "* **[" ++ name ++ "](" ++ instUrl name imp ++ ")**" ++
-        concat [" - from the library [" ++ pkg ++ "](" ++ pkgUrl pkg ++ ")" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp]
-
-pkgUrl x = "http://hackage.haskell.org/package/" ++ x
-
-instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"
-instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam
-    where
-        (a,b) = break (== '-') $ fromMaybe "base" $ importPkg x
-        pkgName = a
-        pkgVersion = if null b then "latest" else tail b
-        modu = reps '.' '-' $ prettyPrint $ importModule x
-        nam = case importSpecs x of Just (False,IAbs _ y:_) -> prettyPrint y ; _ -> name
-
-
-wrap :: Int -> String -> [String]
-wrap n = f . lexemes
-    where
-        f [] = []
-        f (x:xs) = [reverse $ dropWhile isSpace $ reverse $ concat $ x:a] ++ f (dropWhile (all isSpace) b)
-            where (a,b) = thisLine (n - length x) xs
-
-        thisLine i [] = ([], [])
-        thisLine i (x:xs) | j > i = ([], x:xs)
-                          | otherwise = (x:a, b)
-            where j = length x
-                  (a,b) = thisLine (i - j) xs
-
-
-lexemes :: String -> [String]
-lexemes [] = []
-lexemes x = a : lexemes b
-    where (a,b) = lexeme x 
-
-
-lexeme :: String -> (String, String)
-lexeme xs@(x:_) | isAlpha x = span isAlpha xs
-lexeme ('\"':xs) = let (a,b) = f xs in ('\"':a,b)
-    where f ('\\':x:xs) = let (a,b) = f xs in ('\\':x:a,b)
-          f ('\"':xs) = ("\"",xs)
-          f (x:xs) = let (a,b) = f xs in (x:a,b)
-          f [] = ([],[])
-lexeme (x:xs) = ([x], xs)
diff --git a/Derive/Main.hs b/Derive/Main.hs
deleted file mode 100644
--- a/Derive/Main.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-
-module Derive.Main(deriveMain) where
-
-import Language.Haskell
-import Data.Derive.All(Derivation)
-import Derive.Derivation
-import Derive.Generate
-import Derive.Test
-import Derive.Flags
-import Data.List
-import System.Directory
-
-
-deriveMain :: [Derivation] -> IO ()
-deriveMain derivations = do
-    (flags,files) <- getFlags
-    if Test `elem` flags then
-        test
-     else if Generate `elem` flags then
-        generate
-     else if Preprocessor `elem` flags then
-        (if length files /= 3 then
-            error $ "Expected to be invoked as a GHC preprocessor with 3 files, but got " ++ show (length files)
-         else do
-            copyFile (files !! 1) (files !! 2)
-            mainFile derivations (Append:flags) (files !! 2)
-         )
-     else if null files then
-        putStr $ "No files specified\n" ++ flagInfo
-     else
-        mapM_ (mainFile derivations flags) files
-
-
-mainFile :: [Derivation] -> [Flag] -> FilePath -> IO ()
-mainFile derivations flags file = do
-    src <- readFile file
-    src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src
-    let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions}
-        real = parse src
-        mine = parse $ uncomment src
-    flags <- return $ foldl addFlags flags
-        [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]
-    let res = performDerive derivations mine $ wantDerive flags real mine
-    writeDerive file (moduleName mine) flags res
-
-
-uncomment :: String -> String
-uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs
-uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs
-uncomment (x:xs) = x:uncomment xs
-uncomment [] = []
-
-
--- Taken from HLint, update occasionally
-defaultExtensions :: [Extension]
-defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions
-
-badExtensions =
-    [Arrows -- steals proc
-    ,TransformListComp -- steals the group keyword
-    ,XmlSyntax, RegularPatterns -- steals a-b
-    ]
-
diff --git a/Derive/Test.hs b/Derive/Test.hs
deleted file mode 100644
--- a/Derive/Test.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-
-module Derive.Test(test) where
-
-import Derive.Utils
-import Data.Derive.DSL.HSE
-import Control.Monad
-import Data.Maybe
-import Data.List
-import System.FilePath
-import System.Process
-import System.Exit
-import Control.Arrow
-import Data.Derive.All
-import Data.Derive.Internal.Derivation
-
-
--- These overlap with other derivations
-overlaps =
-    [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]
-    ,["Serialize"]]
-
--- REASONS:
--- UniplateDirect: Doesn't work through Template Haskell
--- Typeable cannot be separately derived in GHC 7.8
-exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]
-
--- These must be first and in every set
-priority = ["Eq"]
-
-
-listType :: Decl
-listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
-    [QualConDecl sl [] [] (ConDecl (Ident "[]") [])
-    ,QualConDecl sl [] [] (ConDecl (Ident "Cons")
-        [TyVar (Ident "a")
-        ,TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a"))])]
-    []
-
-
--- test each derivation
-test :: IO ()
-test = do
-    decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"
-
-    -- check the test bits
-    let ts = ("[]",listType) : map (dataDeclName &&& id) decls
-    mapM_ (testFile ts) derivations
-
-    -- check the $(derive) bits
-    putStrLn "Type checking examples"
-    let name = "AutoGenerated_Test"
-    devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]
-    let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs
-
-    let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $
-            [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps
-
-    forM sets $ \(i,xs) -> autoTest (name++show i) decls xs
-    writeFile (name++".hs") $ unlines $
-        ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]
-    res <- system $ "runhaskell " ++ name ++ ".hs"
-    when (res /= ExitSuccess) $ error "Failed to typecheck results"
-
-
-testFile :: [(String,Decl)] -> Derivation -> IO ()
-testFile types (Derivation name op) = do
-    putStrLn $ "Testing " ++ name
-    src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"
-    forM_ (srcTest src) $ \(typ,res) -> do
-        let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ
-        let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types
-        let Right r = op typ grab (ModuleName "Example", grab d)
-        when (not $ r `outEq` res) $
-            error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r
-
-detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb
-    where na = length as ; nb = length bs
-
-detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b
-    where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)
-
-
-autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()
-autoTest name ts ds =
-    writeFile (name++".hs") $ unlines $
-        ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators,DeriveDataTypeable #-}"
-        ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"
-        ,"module " ++ name ++ " where"
-        ,"import Prelude"
-        ,"import Data.DeriveTH"
-        ,"import Data.Typeable"
-        ,"import Derive.TestInstances()"] ++
-        [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++
-        [prettyPrint t ++ "\n  deriving Typeable" | t <- ts2] ++
-        ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]
-    where
-        types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"
-        ts2 = filter (not . isBuiltIn) ts
-
-isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
diff --git a/Derive/Utils.hs b/Derive/Utils.hs
deleted file mode 100644
--- a/Derive/Utils.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-
-module Derive.Utils where
-
-import Data.Derive.DSL.HSE
-import Data.List
-import qualified Data.ByteString.Char8 as BS
-import System.Directory
-import System.IO
-import System.FilePath
-import Control.Monad
-import Data.Maybe
-
-
-data Src = Src
-    {srcName :: String
-    ,srcImport :: [ImportDecl]
-    ,srcExample :: Maybe [Decl]
-    ,srcTest :: [(Type,[Decl])]
-    ,srcCustom :: Bool
-    }
-
--- skip the importPkg bits
-srcImportStd :: Src -> [ImportDecl]
-srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]
-
-nullSrc = Src "" [] Nothing [] False
-
-
-readHSE :: FilePath -> IO Module
-readHSE file = do
-    src <- readFile' file
-    src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $
-                    dropWhile (not . isPrefixOf "module ") $ lines src
-
-    let mode = defaultParseMode{extensions=map EnableExtension [MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}
-    return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src
-
-
-data Pragma = Example Bool | Test Type
-
-asPragma :: Decl -> Maybe Pragma
-asPragma (TypeSig _ [x] t)
-    | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"
-    | x ~= "test" = Just $ Test t
-asPragma _ = Nothing
-
-
-readSrc :: FilePath -> IO Src
-readSrc file = do
-    modu <- readHSE file
-    return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}
-        [ (p,xs)
-        | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]
-        , let xs = takeWhile (isNothing . asPragma) real ]
-    where
-        f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}
-        f src (Test    x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}
-
-
-generatedStart = "-- GENERATED START"
-generatedStop  = "-- GENERATED STOP"
-
-
-
-writeGenerated :: FilePath -> [String] -> IO ()
-writeGenerated file x = do
-    src <- fmap lines $ readFile' file
-    let pre = takeWhile (/= generatedStart) src
-        post = drop 1 $ dropWhile (/= generatedStop) src
-        src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post
-    when (src /= src2) $
-        seq (length src2) $ writeBinaryFile file $ unlines src2
-
-
-readFile' :: FilePath -> IO String
-readFile' file = do
-    b <- doesFileExist file
-    if b then fmap BS.unpack $ BS.readFile file else return []
-
-
-writeBinaryFile :: FilePath -> String -> IO ()
-writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)
-
-
-rep from to x = if x == from then to else x
-reps from to = map (rep from to)
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright Neil Mitchell 2006-2015.
+Copyright Neil Mitchell 2006-2016.
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/Language/Haskell.hs b/Language/Haskell.hs
deleted file mode 100644
--- a/Language/Haskell.hs
+++ /dev/null
@@ -1,300 +0,0 @@
-
-module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where
-
-import Language.Haskell.Exts hiding (var,app,binds,paren)
-import Data.List
-import Data.Generics.Uniplate.Data
-import Data.Data
-import Data.Char
-import Data.Maybe
-
-
-infix 1 ?
-True ? b = const b
-False ? b = id
-
-
-
--- insert explicit foralls
-foralls :: Type -> Type
-foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x
-
-
-tyApps x [] = x
-tyApps x (y:ys) = tyApps (TyApp x y) ys
-
-
-fromTyApps (TyTuple _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)
-fromTyApps (TyApp x y) = let (a,b) = fromTyApps x in (a, b ++ [y])
-fromTyApps (TyList x) = (TyCon $ Special ListCon, [x])
-fromTyApps x = (x, [])
-
-fromTyTuple (TyTuple _ xs) = xs
-fromTyTuple x = [x]
-
-fromTyParen (TyParen x) = fromTyParen x
-fromTyParen x = x
-
-fromTyParens = transform fromTyParen
-
-tyRoot = prettyPrint . fst . fromTyApps . fromTyParen
-
-isTyFun TyFun{} = True
-isTyFun _ = False
-
-isTyParen TyParen{} = True ; isTyParen _ = False
-
-fromTyList (TyList x) = Just x
-fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x
-fromTyList x = Nothing
-
-
-x ~= y = prettyPrint x == y
-
-
-appP x@App{} y = App x y
-appP x y = App (paren x) (paren y)
-
-
-simplify :: Data a => a -> a
-simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp
-    where
-        fExp (App op (List xs))
-            | op ~= "length" = Lit $ Int $ fromIntegral $ length xs
-            | op ~= "head" = head xs
-            | op ~= "null" = con $ show $ null xs
-        fExp (InfixApp (Lit (Int i)) op (Lit (Int j)))
-            | op ~= "-" = Lit $ Int $ i - j
-            | op ~= "+" = Lit $ Int $ i + j
-            | op ~= ">" = Con $ UnQual $ Ident $ show $ i > j
-        fExp (InfixApp x op y)
-            | op ~= "`const`" = x
-            | op ~= "&&" && y ~= "True" = x
-            | x ~= "id" && op ~= "." = y
-            | y ~= "id" && op ~= "." = x
-        fExp (InfixApp (Lit (String x)) op (Lit (String y))) | op ~= "++" = Lit $ String $ x ++ y
-        fExp (App (App (App flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x        
-        fExp (App (Paren x@App{}) y) = fExp $ App x y
-        fExp (App (Paren (InfixApp x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z
-        fExp (App op x) | op ~= "id" = x
-        fExp (App (App flp con) x) | flp ~= "flip" && con ~= "const" = var "id"
-        fExp (App (App con x) y) | con ~= "const" = x
-        fExp (App choose (Tuple _ [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App (var "return") x
-        fExp (App op x) | op ~= "id" = x
-        fExp (InfixApp (App when true) dot res)
-            | when ~= "when" && true ~= "True" = res
-        fExp (InfixApp x y z) | y ~= "++" && z ~= "[]" = x
-        fExp (App (LeftSection x op) y) = fExp $ InfixApp x op (paren y)
-        fExp (Paren x) | isAtom x = x
-        fExp (Do [Qualifier x]) = x
-        fExp (Do (Qualifier (App ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do xs
-        fExp (Do (Generator _ (PVar x) (App ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do $ subst x2 y xs
-            where x2 = Var $ UnQual x
-        fExp (Case (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case x alts
-        fExp (Case (Lit x) alts) | good /= [] = head good
-            where good = [z | Alt _ (PLit Signless y) (UnGuardedRhs z) Nothing <- alts, y == x]
-        fExp (If x t f)
-            | x ~= "True" = t
-            | x ~= "False" = f
-        fExp (App (App when b) x)
-            | when ~= "when" && b ~= "True" = x
-            | when ~= "when" && b ~= "False" = App (Var $ UnQual $ Ident "return") (Con $ Special $ TupleCon Boxed 0)
-        fExp (App (Paren (Lambda _ [PVar x] y)) z) | once x2 y = fExp $ subst x2 z y
-            where x2 = Var $ UnQual x
-        fExp (App (Paren (Lambda _ [PWildCard] x)) _) = x
-        fExp (Lambda s ps x) = Lambda s (minPat x ps) x
-        fExp (Con x) = Con $ rename x
-        fExp x = x
-
-        fTyp (TyApp x y) | x ~= "[]" = TyList y
-        fTyp (TyApp (TyCon (Special ListCon)) x) = TyList x
-        fTyp (TyParen x@TyCon{}) = x
-        fTyp (TyParen x@TyVar{}) = x
-        fTyp (TyParen x@TyList{}) = x
-        fTyp (TyCon nam) = TyCon $ rename nam
-        fTyp x = x
-
-        fPat (PParen x@(PApp _ [])) = x
-        fPat (PParen (PParen x)) = PParen x
-        fPat (PApp nam xs) = case rename nam of
-            Special (TupleCon Boxed _) -> PTuple Boxed xs
-            nam -> PApp nam xs
-        fPat (PParen (PTuple l xs)) = PTuple l xs
-        fPat x = x
-
-        fMatch (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls)
-            | x ~= "True" = fMatch $ Match sl nam pat sig (UnGuardedRhs bod) decls
-        fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedRhs y) Nothing])) decls)
-            | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls
-        fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind
-
-        fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind
-        fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs
-        fDecl x = x
-
-        fBinds context Nothing = context Nothing
-        fBinds context (Just (BDecls bind)) | inline /= [] =
-                simplify $ subst (Var $ UnQual from) to $ context $
-                    let xs = take i bind ++ drop (i+1) bind in if null xs then Nothing else Just $ BDecls xs
-            where
-                f (PatBind _ (PVar x) (UnGuardedRhs bod) Nothing) = [(x,bod)]
-                f (FunBind [Match _ x [PVar v] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) Nothing])
-                    | UnQual v == v2 = [(x,bod)]
-                f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) Nothing]) = [(x,Paren $ Lambda sl pat bod)]
-                f _ = []
-
-                (i,from,to) = head inline
-                inline = [(i, x, bod)
-                         | (i,b) <- zip [0..] bind, (x,bod) <- f b
-                         , isAtom bod || once (Var $ UnQual x) (context $ Just $ BDecls bind)]
-        fBinds a y = a y
-
-        subst from to = transformBi $ \x -> if x == from then to else x
-        once x y = length (filter (== x) (universeBi y)) <= 1  
-
-        minPat o ps = transformBi f ps
-            where
-                known = nub [x | UnQual x <- universeBi o]
-                f (PVar x) | x `notElem` known = PWildCard
-                f (PAsPat x y) | x `notElem` known = y
-                f x = x
-
-
-
-isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False"
-isGuardFalse _ = False
-
-
-rename (UnQual (Ident ('(':xs@(x:_))))
-    | x == ',' = Special $ TupleCon Boxed $ length xs
-    | x /= ')' = UnQual $ Symbol $ init xs
-rename x = x
-
-
-isAtom Con{} = True
-isAtom Var{} = True
-isAtom Lit{} = True
-isAtom Paren{} = True
-isAtom _ = False
-
-
-paren x = if isAtom x then x else Paren x
-
-sl = SrcLoc "" 0 0
-
-noSl mr = transformBi (const sl) mr
-
-
-isIdent (x:xs) = isAlpha x || x == '_'
-title (x:xs) = toUpper x : xs
-
-qname = UnQual . name
-var = Var . qname
-con = Con . qname
-tyVar = TyVar . name
-tyVarBind = UnkindedVar . name
-tyCon = TyCon . qname
-pVar = PVar . name
-qvop = QVarOp . UnQual . Symbol
-
-dataDeclType :: DataDecl -> Type
-dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)
-
-dataDeclFields :: DataDecl -> [String]
-dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors
-
-
--- A declaration that is either a DataDecl of GDataDecl
-type DataDecl = Decl
-type CtorDecl = Either QualConDecl GadtDecl
-type FieldDecl = [(String, Type)]
-
-type FullDataDecl = (ModuleName, DataDecl)
-
-
-moduleName (Module _ name _ _ _ _ _) = name
-moduleDecls (Module _ _ _ _ _ _ decls) = decls
-moduleImports (Module _ _ _ _ _ imps _) = imps
-modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas
-
-
-showDecls x = unlines $ map prettyPrint x
-
-
-tyApp x [] = x
-tyApp x xs = TyApp (tyApp x $ init xs) (last xs)
-
-
-tyFun [x] = x
-tyFun (x:xs) = TyFun x (tyFun xs)
-
-
-apps x [] = x
-apps x (y:ys) = apps (App x y) ys
-
-
-bind :: String -> [Pat] -> Exp -> Decl
-bind s p e = binds s [(p,e)]
-
-binds :: String -> [([Pat], Exp)] -> Decl
-binds n [([],e)] = PatBind sl (pVar n) (UnGuardedRhs e) Nothing
-binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) Nothing | (p,e) <- xs]
-
-
-isDataDecl :: Decl -> Bool
-isDataDecl DataDecl{} = True
-isDataDecl GDataDecl{} = True
-isDataDecl _ = False
-
-
-dataDeclSrcLoc :: DataDecl -> SrcLoc
-dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl
-dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl
-
-dataDeclContext :: DataDecl -> Context
-dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx
-dataDeclContext _ = error "dataDeclContext: not a DataDecl"
-
-dataDeclName :: DataDecl -> String
-dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name
-dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
-
-dataDeclVars :: DataDecl -> [String]
-dataDeclVars (DataDecl _ _ _ _ vars _ _) = map f vars
-    where f (KindedVar x _) = prettyPrint x
-          f (UnkindedVar x) = prettyPrint x
-
-dataDeclVarsStar :: DataDecl -> [String]
-dataDeclVarsStar (DataDecl _ _ _ _ vars _ _) = mapMaybe f vars
-    where f (UnkindedVar x) = Just $ prettyPrint x
-          f (KindedVar x KindStar) = Just $ prettyPrint x
-          f _ = Nothing
-
-dataDeclArity :: DataDecl -> Int
-dataDeclArity = length . dataDeclVars
-
-dataDeclCtors :: DataDecl -> [CtorDecl]
-dataDeclCtors (DataDecl _ _ _ _ _ ctors _) = map Left ctors
-
-
-ctorDeclName :: CtorDecl -> String
-ctorDeclName = prettyPrint . ctorDeclName'
-
-ctorDeclName' :: CtorDecl -> Name
-ctorDeclName' (Left (QualConDecl _ _ _ (ConDecl name _))) = name
-ctorDeclName' (Left (QualConDecl _ _ _ (InfixConDecl _ name _))) = name
-ctorDeclName' (Left (QualConDecl _ _ _ (RecDecl name _))) = name
-
-ctorDeclFields :: CtorDecl -> FieldDecl
-ctorDeclFields (Left (QualConDecl _ _ _ (ConDecl name fields))) = map ((,) "") fields
-ctorDeclFields (Left (QualConDecl _ _ _ (InfixConDecl x1 name x2))) = map ((,) "") [x1,x2]
-ctorDeclFields (Left (QualConDecl _ _ _ (RecDecl name fields))) = [(prettyPrint a, b) | (as,b) <- fields, a <- as]
-
-ctorDeclArity :: CtorDecl -> Int
-ctorDeclArity = length . ctorDeclFields
-
-declName :: Decl -> String
-declName (DataDecl _ _ _ name _ _ _) = prettyPrint name
-declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
-declName (TypeDecl _ name _ _) = prettyPrint name
-
diff --git a/Language/Haskell/Convert.hs b/Language/Haskell/Convert.hs
deleted file mode 100644
--- a/Language/Haskell/Convert.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
-
-module Language.Haskell.Convert(Convert, convert) where
-
-import Language.Haskell as HS
-import Language.Haskell.TH.Syntax as TH
-import Control.Exception
-import Data.Typeable
-import System.IO.Unsafe
-import Data.Maybe
-
-
-class (Typeable a, Typeable b, Show a, Show b) => Convert a b where
-    conv :: a -> b
-
-
-convert :: forall a b . Convert a b => a -> b
-convert a = unsafePerformIO $
-        (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)
-    where
-        msg e = "Could not convert " ++ show (typeOf a) ++ " to " ++
-                show (typeOf (undefined :: b)) ++ "\n" ++ show a ++
-                "\n" ++ show e
-
-
-
-appT :: TH.Type -> [TH.Type] -> TH.Type
-appT = foldl AppT
-
-c mr = convert mr
-
-instance Convert a b => Convert [a] [b] where
-    conv = map c
-
-
-
-instance Convert TH.Dec HS.Decl where
-    conv x = case x of
-        DataD cxt n vs con ds -> f DataType cxt n vs con ds
-        NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds
-        where
-            f :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl
-            f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
-
-instance Convert TH.Name HS.TyVarBind where
-    conv = UnkindedVar . c
-
-instance Convert TH.Name HS.Name where
-    conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2
-        where x2 = show x
-
-instance Convert TH.Name HS.QName where
-    conv x = if x2 == Ident "[]" then Special ListCon else UnQual x2
-        where x2 = c x
-
-instance Convert TH.Con HS.QualConDecl where
-    conv (ForallC vs cxt x) = QualConDecl sl (c vs) (c cxt) (c x)
-    conv x = QualConDecl sl [] [] (c x)
-
-instance Convert TH.Con HS.ConDecl where
-    conv (NormalC n xs) = ConDecl (c n) (c xs)
-    conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs]
-    conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y)
-
-instance Convert TH.StrictType HS.Type where
-    conv (IsStrict, x) = TyBang BangedTy $ c x
-    conv (NotStrict, x) = c x
-#if __GLASGOW_HASKELL__ >= 704
-    conv (Unpacked, x) = TyBang UnpackedTy $ c x
-#endif
-
-instance Convert TH.Type HS.Type where
-    conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t)
-    conv (VarT x) = TyVar $ c x
-    conv (ConT x) | ',' `elem` show x = TyTuple Boxed []
-                  | otherwise = TyCon $ c x
-    conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y)
-    conv (ArrowT) = TyCon $ Special FunCon
-    conv (AppT ListT x) = TyList $ c x
-    conv (ListT) = TyCon $ Special ListCon
-    conv (TupleT _) = TyTuple Boxed []
-    conv (AppT x y) = case c x of
-        TyTuple b xs -> TyTuple b $ xs ++ [c y]
-        x -> TyApp x $ c y
-
-instance Convert TH.Type HS.Asst where
-    conv (ConT x) = ClassA (UnQual $ c x) []
-    conv (AppT x y) = case c x of
-        ClassA a b -> ClassA a (b ++ [c y])
-
-
-
-instance Convert HS.Decl TH.Dec where
-    conv (InstDecl _ _ _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds]
-    conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms)
-    conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds)
-    conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)
-    conv (DataDecl _ DataType ctx nam typ cs ds) =
-      DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds))
-    conv (DataDecl _ NewType ctx nam typ [con] ds) =
-      NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds))
-
-instance Convert HS.QualConDecl TH.Con where
-    conv (QualConDecl _ [] [] con) = c con
-    conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con)
-
-instance Convert HS.ConDecl TH.Con where
-    conv (ConDecl nam typ) = NormalC (c nam) (c typ)
-    conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r)
-    conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs)
-
-instance Convert HS.Type TH.StrictType where
-    conv (TyBang BangedTy t) = (IsStrict, c t)
-#if __GLASGOW_HASKELL__ >= 704
-    conv (TyBang UnpackedTy t) = (Unpacked, c t)
-#else
-    conv (TyBang UnpackedTy t) = (IsStrict, c t)
-#endif
-    conv t = (NotStrict, c t)
-
-instance Convert ([HS.Name],HS.Type) [TH.VarStrictType] where
-    conv (names,bt) = [(c name,s,t) | name <- names]
-     where (s,t) = c bt
-
-instance Convert HS.Asst TH.Type where
-    conv (InfixA x y z) = c $ ClassA y [x,z]
-    conv (ClassA x y) = appT (ConT $ c x) (c y)
-
-instance Convert HS.Type TH.Type where
-    conv (TyCon (Special ListCon)) = ListT
-    conv (TyCon (Special UnitCon)) = TupleT 0
-    conv (TyParen x) = c x
-    conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)
-    conv (TyVar x) = VarT $ c x
-    conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x
-    conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y)
-    conv (TyList x) = AppT ListT (c x)
-    conv (TyTuple _ x) = appT (TupleT (length x)) (c x)
-    conv (TyApp x y) = AppT (c x) (c y)
-
-instance Convert HS.Name TH.Name where
-    conv = mkName . filter (`notElem` "()") . prettyPrint
-
-instance Convert HS.Match TH.Clause where
-    conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds)
-
-instance Convert HS.Rhs TH.Body where
-    conv (UnGuardedRhs x) = NormalB (c x)
-    conv (GuardedRhss x) = GuardedB (c x)
-
-instance Convert HS.Exp TH.Exp where
-    conv (Con (Special UnitCon)) = TupE []
-    conv (Var x) = VarE (c x)
-    conv (Con x) = ConE (c x)
-    conv (Lit x) = LitE (c x)
-    conv (App x y) = AppE (c x) (c y)
-    conv (Paren x) = c x
-    conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z)
-    conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing
-    conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z)
-    conv (Lambda _ x y) = LamE (c x) (c y)
-    conv (Tuple _ x) = TupE (c x)
-    conv (If x y z) = CondE (c x) (c y) (c z)
-    conv (Let x y) = LetE (c x) (c y)
-    conv (Case x y) = CaseE (c x) (c y)
-    conv (Do x) = DoE (c x)
-    conv (EnumFrom x) = ArithSeqE $ FromR (c x)
-    conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y)
-    conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y)
-    conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)
-    conv (List x) = ListE (c x)
-    conv (ExpTypeSig _ x y) = SigE (c x) (c y)
-    conv (RecConstr x y) = RecConE (c x) (c y)
-    conv (RecUpdate x y) = RecUpdE (c x) (c y) 
-    -- Work around bug 3395, convert to do notation instead
-    conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x]
-
-instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where
-    conv = undefined
-
-instance Convert HS.Binds [TH.Dec] where
-    conv (BDecls x) = c x
-
-instance Convert (Maybe HS.Binds) [TH.Dec] where
-    conv Nothing = []
-    conv (Just x) = c x
-
-instance Convert HS.Pat TH.Pat where
-    conv (PParen x) = c x
-    conv (PLit Signless x) = LitP (c x)
-    conv (PTuple _ x) = TupP (c x)
-    conv (PApp x y) = ConP (c x) (c y)
-    conv (PVar x) = VarP (c x)
-    conv (PInfixApp x y z) = InfixP (c x) (c y) (c z)
-    conv (PIrrPat x) = TildeP (c x)
-    conv (PAsPat x y) = AsP (c x) (c y)
-    conv (PWildCard) = WildP
-    conv (PRec x y) = RecP (c x) (c y)
-    conv (PList x) = ListP (c x)
-    conv (PatTypeSig _ x y) = SigP (c x) (c y)
-
-instance Convert HS.Literal TH.Lit where
-    conv (Char x) = CharL x
-    conv (String x) = StringL x
-    conv (Int x) = IntegerL x
-    conv (Frac x) = RationalL x
-    conv (PrimInt x) = IntPrimL x
-    conv (PrimWord x) = WordPrimL x
-    conv (PrimFloat x) = FloatPrimL x
-    conv (PrimDouble x) = DoublePrimL x
-
-instance Convert HS.QName TH.Name where
-    conv (UnQual x) = c x
-    conv (Qual m x) = c (Ident $ prettyPrint m ++ "." ++ prettyPrint x)
-    conv (Special (TupleCon Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS
-
-instance Convert HS.PatField TH.FieldPat where
-    conv = undefined
-
-instance Convert HS.QOp TH.Exp where
-    conv (QVarOp x) = c $ Var x
-    conv (QConOp x) = c $ Con x
-
-instance Convert HS.Alt TH.Match where
-    conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)
-
-instance Convert HS.Stmt TH.Stmt where
-    conv (Generator _ x y) = BindS (c x) (c y)
-    conv (LetStmt x) = LetS (c x)
-    conv (Qualifier x) = NoBindS (c x)
-
-instance Convert HS.QualStmt TH.Stmt where
-    conv (QualStmt x) = c x
-
-instance Convert HS.FieldUpdate TH.FieldExp where
-    conv (FieldUpdate x y) = (c x, c y)
-
-instance Convert HS.TyVarBind TH.Name where
-    conv (UnkindedVar x) = c x
-
-#if __GLASGOW_HASKELL__ >= 612
-instance Convert TH.TyVarBndr HS.TyVarBind where
-    conv (PlainTV x) = UnkindedVar $ c x
-    conv (KindedTV x y) = KindedVar (c x) $ c y
-
-#if __GLASGOW_HASKELL__ < 706
-instance Convert TH.Kind HS.Kind where
-    conv StarK = KindStar
-    conv (ArrowK x y) = KindFn (c x) $ c y
-#else
-instance Convert TH.Kind HS.Kind where
-    conv StarT = KindStar
-    conv (AppT (AppT ArrowT x) y) = KindFn (c x) (c y)
-#endif
-
-#if __GLASGOW_HASKELL__ < 709
-instance Convert TH.Pred HS.Asst where
-    conv (ClassP x y) = ClassA (UnQual $ c x) $ c y
-    conv (TH.EqualP x y) = HS.EqualP (c x) $ c y
-
-instance Convert HS.Asst TH.Pred where
-    conv (ClassA x y) = ClassP (c x) $ c y
-    conv (HS.EqualP x y) = TH.EqualP (c x) $ c y
-#endif
-
-instance Convert HS.TyVarBind TH.TyVarBndr where
-    conv (UnkindedVar x) = PlainTV $ c x
-    conv (KindedVar x y) = KindedTV (c x) $ c y
-
-#if __GLASGOW_HASKELL__ < 706
-instance Convert HS.Kind TH.Kind where
-    conv KindStar = StarK
-    conv (KindFn x y) = ArrowK (c x) $ c y
-#else
-instance Convert HS.Kind TH.Kind where
-    conv KindStar = StarT
-    conv (KindFn x y) = AppT (AppT ArrowT (c x)) (c y)
-#endif
-#endif
diff --git a/Language/Haskell/TH/All.hs b/Language/Haskell/TH/All.hs
deleted file mode 100644
--- a/Language/Haskell/TH/All.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# OPTIONS_GHC -w #-}
-
-module Language.Haskell.TH.All (
-    module Language.Haskell.TH.All,
-    module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,
-    module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr,
-    module Language.Haskell.TH.Data,   module Language.Haskell.TH.ExpandSynonym,
-    ) where
-
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Peephole
-import Language.Haskell.TH.Helper
-import Language.Haskell.TH.FixedPpr
-import Language.Haskell.TH.ExpandSynonym
-import Language.Haskell.TH.Data
-
-import Control.Monad
-
-
-
--- | The type of ways to derive classes.
---   Should not really be in this module!
-data Derivation = Derivation {
-      derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper
-      derivationName    :: String              -- ^ The name of the derivation
-    }
-
-
--- create a new derivation more abstractly
-derivation :: (DataDef -> [Dec]) -> String -> Derivation
-derivation f = Derivation (return . f)
-
-
-derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation
-derivationQ = Derivation
diff --git a/Language/Haskell/TH/Compat.hs b/Language/Haskell/TH/Compat.hs
deleted file mode 100644
--- a/Language/Haskell/TH/Compat.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-{-# LANGUAGE CPP #-}
-
--- | Compatibility definitions to paper over differences between 6.10 and 6.12.
-module Language.Haskell.TH.Compat where
-
-import Language.Haskell.TH
-
-
-#if __GLASGOW_HASKELL__ >= 612
-fromTyVar :: TyVarBndr -> Name
-fromTyVar (PlainTV v) = v
-fromTyVar (KindedTV v _) = v
-#else
-fromTyVar :: Name -> Name
-fromTyVar v = v
-#endif
-
-
-dataDefinitionTypeArgs :: Dec -> [Name]
-#if __GLASGOW_HASKELL__ >= 612
-dataDefinitionTypeArgs (DataD _cx name _ _ args) = args
-dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args
-#else
-dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args
-dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args
-#endif
-
-#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 709
-typeToPred :: Type -> Pred
-typeToPred (ConT v) = ClassP v []
-typeToPred (AppT x y) = ClassP v (t++[y])
-    where ClassP v t = typeToPred x
-#else
-typeToPred :: Type -> Type
-typeToPred x = x
-#endif
diff --git a/Language/Haskell/TH/Data.hs b/Language/Haskell/TH/Data.hs
deleted file mode 100644
--- a/Language/Haskell/TH/Data.hs
+++ /dev/null
@@ -1,119 +0,0 @@
-
--- | The core module of the Data.Derive system.  This module contains
--- the data types used for communication between the extractors and
--- the derivors.
-module Language.Haskell.TH.Data where
-
-import Data.Char
-import Data.Generics
-
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Compat
-
-
--- must be one of DataD or NewtypeD
-type DataDef = Dec
-
-type CtorDef = Con
-
-
-dataName :: DataDef -> String
-dataName (DataD    _ name _ _ _) = unqualifiedName name
-dataName (NewtypeD _ name _ _ _) = unqualifiedName name
-
-qualifiedDataName :: DataDef -> Name
-qualifiedDataName (DataD    _ name _ _ _) = name
-qualifiedDataName (NewtypeD _ name _ _ _) = name
-
-dataArity :: DataDef -> Int
-dataArity (DataD    _ _ xs _ _) = length xs
-dataArity (NewtypeD _ _ xs _ _) = length xs
-
-dataArgs :: DataDef -> [Name]
-dataArgs = dataDefinitionTypeArgs
-
-
-dataCtors :: DataDef -> [CtorDef]
-dataCtors (DataD    _ _ _ xs _) = xs
-dataCtors (NewtypeD _ _ _ x  _) = [x]
-
-
-ctorName :: CtorDef -> String
-ctorName (NormalC name _ ) = unqualifiedName name
-ctorName (RecC name _    ) = unqualifiedName name
-ctorName (InfixC _ name _) = unqualifiedName name
-ctorName (ForallC _ _ c  ) = ctorName c
-
-qualifiedCtorName :: CtorDef -> Name
-qualifiedCtorName (NormalC name _ ) = name
-qualifiedCtorName (RecC name _    ) = name
-qualifiedCtorName (InfixC _ name _) = name
-qualifiedCtorName (ForallC _ _ c  ) = qualifiedCtorName c
-
-
-ctorArity :: CtorDef -> Int
-ctorArity (NormalC _ xs ) = length xs
-ctorArity (RecC _ xs    ) = length xs
-ctorArity (InfixC _ _ _ ) = 2
-ctorArity (ForallC _ _ c) = ctorArity c
-
-
-ctorStrictTypes :: CtorDef -> [StrictType]
-ctorStrictTypes (NormalC _ xs ) = xs
-ctorStrictTypes (RecC _ xs    ) = [(b,c) | (a,b,c) <- xs]
-ctorStrictTypes (InfixC x _ y ) = [x,y]
-ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c
-
-
-ctorTypes :: CtorDef -> [Type]
-ctorTypes = map snd . ctorStrictTypes
-
-
-ctorFields :: CtorDef -> [String]
-ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType]
-ctorFields _ = []
-
-
--- normalisation
-
--- make sure you deal with "GHC.Base.."
-dropModule :: String -> String
-dropModule xs = case reverse xs of
-                    ('.':xs) -> takeWhile (== '.') xs
-                    xs -> reverse $ takeWhile (/= '.') xs
-
--- i_123432 -> i
-dropNumber :: String -> String
-dropNumber xs = if all isDigit a then reverse (tail b) else xs
-    where (a,b) = break (== '_') $ reverse xs
-
-
-normData :: DataDef -> DataDef
-normData = everywhere (mkT normType)
-    where
-        normType :: Type -> Type
-        normType (ConT x) | show x == "[]" = ListT
-        normType x = x
-
-unqualifiedName :: Name -> String
-unqualifiedName = dropModule . show
-
-
--- convert AppT chains back to a proper list
-typeApp :: Type -> (Type, [Type])
-typeApp (AppT l r) = (a, b++[r])
-    where (a,b) = typeApp l
-typeApp t = (t, [])
-
-
-
-eqConT :: String -> Type -> Bool
-eqConT name (ConT x) = name == show x
-eqConT _ _ = False
-
-isTupleT :: Type -> Bool
-isTupleT (TupleT _) = True
-isTupleT (ConT x) = head sx == '(' && last sx == ')' &&
-                    all (== ',') (take (length sx - 2) (tail sx))
-    where sx = nameBase x
-isTupleT _ = False
diff --git a/Language/Haskell/TH/ExpandSynonym.hs b/Language/Haskell/TH/ExpandSynonym.hs
deleted file mode 100644
--- a/Language/Haskell/TH/ExpandSynonym.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-
--- | Expand type synonyms in data declarations.
--- 
---   This is needed for some type based derivations.
-module Language.Haskell.TH.ExpandSynonym (expandData) where
-
-import Language.Haskell.TH
-import Language.Haskell.TH.Compat
-import Language.Haskell.TH.Data
-import Data.Generics
-
--- | Expand type synonyms in a data declaration
-expandData :: DataDef -> Q DataDef
-expandData = everywhereM (mkM expandType)
-
-expandType :: Type -> Q Type
-expandType t = expandType' t []
-
--- Walk over a type, collecting applied arguments
-expandType' :: Type -> [Type] -> Q Type
-expandType'   (AppT t arg) args   = expandType' t (arg:args)
-expandType' t@(ConT name)  args   = do result <- expandSyn name args
-                                       case result of
-                                          Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args'
-                                          _               -> return $ foldl AppT t args
-expandType' t              args   = return $ foldl AppT t args
-
--- Is the name a type synonym and are there enough arguments? if so, apply it
-expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type]))
-expandSyn name args = recover (return Nothing) $ do
-            info <- reify name
-            case info of
-                   TyConI (TySynD _ synArgs t) | length args >= length synArgs
-                        -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym
-                             where (argsInst,argsMore) = splitAt (length synArgs) args
-                   _    -> return Nothing
-      -- `recover` return Nothing
-
--- Substitute names for types in a type
-substitute :: [Name] -> [Type] -> Type -> Type
-substitute ns ts = subst (zip ns ts)
-  where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)
-        subst s (VarT n)
-           | Just t' <- lookup n s = t'
-        subst s (AppT a b)         = AppT (subst s a) (subst s b)
-        subst _ t                  = t
diff --git a/Language/Haskell/TH/FixedPpr.hs b/Language/Haskell/TH/FixedPpr.hs
deleted file mode 100644
--- a/Language/Haskell/TH/FixedPpr.hs
+++ /dev/null
@@ -1,414 +0,0 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
--- TH.Ppr contains a prettyprinter for the
--- Template Haskell datatypes
-
-module Language.Haskell.TH.FixedPpr where
-    -- All of the exports from this module should
-    -- be "public" functions.  The main module TH
-    -- re-exports them all.
-
-import Text.PrettyPrint.HughesPJ (render)
-import Language.Haskell.TH.PprLib
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Data(isTupleT)
-import Data.Char ( toLower, isAlpha )
-
-nestDepth :: Int
-nestDepth = 4
-
-type Precedence = Int
-appPrec, opPrec, noPrec :: Precedence
-appPrec = 2    -- Argument of a function application
-opPrec  = 1    -- Argument of an infix operator
-noPrec  = 0    -- Others
-
-parensIf :: Bool -> Doc -> Doc
-parensIf True d = parens d
-parensIf False d = d
-
-------------------------------
-
--- Show name with `` and () stripped, so that behaviour is the same
--- with fixed and broken syntax-libs
-showNameRaw :: Name -> String
-showNameRaw = clean . show
-    where
-        clean ('(':xs) = init xs
-        clean ('`':xs) = init xs
-        clean xs = xs
-
-isPrefixName :: Name -> Bool
-isPrefixName = classify . showNameRaw
-    where
-        classify xs = case break (=='.') xs of
-                            (_,(_:xs')) -> classify xs'
-                            ((x:xs),[]) -> isAlpha x || x == '_'
-                            _ -> False -- operators ending with .
-
-pprName_ :: Bool -> Name -> Doc
-pprName_ True nm  | isPrefixName nm = text (showNameRaw nm)
-                  | otherwise       = text ("(" ++ showNameRaw nm ++ ")")
-pprName_ False nm | isPrefixName nm = text ("`" ++ showNameRaw nm ++ "`")
-                  | otherwise       = text (showNameRaw nm)
-
-------------------------------
-
-pprint :: Ppr a => a -> String
-pprint x = render $ to_HPJ_Doc $ ppr x
-
-class Ppr a where
-    ppr :: a -> Doc
-    ppr_list :: [a] -> Doc
-    ppr_list = vcat . map ppr
-
-instance Ppr a => Ppr [a] where
-    ppr x = ppr_list x
-
-------------------------------
-instance Ppr Name where
-    ppr v = pprName_ True v -- text (show v)
-
-------------------------------
-instance Ppr Info where
-#if __GLASGOW_HASKELL__ >= 700
-    ppr (ClassI d _) = ppr d
-#else
-    ppr (ClassI d) = ppr d
-#endif
-    ppr (TyConI d) = ppr d
-    ppr (PrimTyConI name arity is_unlifted) 
-      = text "Primitive"
-        <+> (if is_unlifted then text "unlifted" else empty)
-        <+> text "type construtor" <+> quotes (ppr name)
-        <+> parens (text "arity" <+> int arity)
-    ppr (ClassOpI v ty cls fix) 
-      = text "Class op from" <+> ppr cls <> colon <+>
-        vcat [ppr_sig v ty, pprFixity v fix]
-    ppr (DataConI v ty tc fix) 
-      = text "Constructor from" <+> ppr tc <> colon <+>
-        vcat [ppr_sig v ty, pprFixity v fix]
-    ppr (TyVarI v ty)
-      = text "Type variable" <+> ppr v <+> equals <+> ppr ty
-    ppr (VarI v ty mb_d fix) 
-      = vcat [ppr_sig v ty, pprFixity v fix, 
-              case mb_d of { Nothing -> empty; Just d -> ppr d }]
-
-ppr_sig v ty = ppr v <+> text "::" <+> ppr ty
-
-pprFixity :: Name -> Fixity -> Doc
-pprFixity v f | f == defaultFixity = empty
-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
-    where ppr_fix InfixR = text "infixr"
-          ppr_fix InfixL = text "infixl"
-          ppr_fix InfixN = text "infix"
-
-
-------------------------------
-instance Ppr Exp where
-    ppr = pprExp noPrec
-
-pprExpInfix :: Exp -> Doc
-pprExpInfix (VarE v) = pprName_ False v
-pprExpInfix (ConE c) = pprName_ False c
-
-pprExp :: Precedence -> Exp -> Doc
-pprExp _ (VarE v)     = ppr v
-pprExp _ (ConE c)     
- | isTupleT (ConT c)  = text (nameBase c)
- | c == '[]           = text ("[]")
- | c == '(:)          = text ("(:)")
- | otherwise          = ppr c
-pprExp i (LitE l)     = pprLit i l
-pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
-                                              <+> pprExp appPrec e2
-pprExp i (InfixE (Just e1) op (Just e2))
- = parensIf (i >= opPrec) $ pprExp opPrec e1
-                        <+> pprExpInfix op
-                        <+> pprExp opPrec e2
-pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
-                                    <+> pprExpInfix op
-                                    <+> pprMaybeExp noPrec me2
-pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
-                                           <+> text "->" <+> ppr e
-pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es
--- Nesting in Cond is to avoid potential problems in do statments
-pprExp i (CondE guard true false)
- = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
-                       nest 1 $ text "then" <+> ppr true,
-                       nest 1 $ text "else" <+> ppr false]
-pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds
-                                            $$ text " in" <+> ppr e
-pprExp i (CaseE e ms)
- = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
-                        $$ nest nestDepth (ppr ms)
-pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss
-pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"
--- This will probably break with fixity declarations - would need a ';'
-pprExp _ (CompE ss) = text "[" <> ppr s
-                  <+> text "|"
-                  <+> (sep $ punctuate comma $ map ppr ss')
-                   <> text "]"
-    where s = last ss
-          ss' = init ss
-pprExp _ (ArithSeqE d) = ppr d
-pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
-pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t
-pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
-
-pprFields :: [(Name,Exp)] -> Doc
-pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
-
-pprMaybeExp :: Precedence -> Maybe Exp -> Doc
-pprMaybeExp _ Nothing = empty
-pprMaybeExp i (Just e) = pprExp i e
-
-------------------------------
-instance Ppr Stmt where
-    ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
-    ppr (LetS ds) = text "let" <+> ppr ds
-    ppr (NoBindS e) = ppr e
-    ppr (ParS sss) = sep $ punctuate (text "|")
-                         $ map (sep . punctuate comma . map ppr) sss
-
-------------------------------
-instance Ppr Match where
-    ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
-                        $$ where_clause ds
-
-------------------------------
-pprBody :: Bool -> Body -> Doc
-pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs
-  where eqd = if eq then text "=" else text "->"
-        do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e
-        do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)
-                             $$ nest nestDepth (eqd <+> ppr e)
-pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e
-
-
-instance Ppr Body where
-    ppr = pprBody True
-
-------------------------------
-pprLit :: Precedence -> Lit -> Doc
-pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)
-                                    (integer x <> char '#')
-pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)
-                                    (float (fromRational x) <> char '#')
-pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
-                                    (double (fromRational x) <> text "##")
-pprLit i (IntegerL x)    = parensIf (i > noPrec && x < 0) (integer x)
-pprLit _ (CharL c)       = text (show c)
-pprLit _ (StringL s)     = text (show s)
-pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat
-
-instance Ppr Lit where
-    ppr = pprLit 10
-
-------------------------------
-instance Ppr Pat where
-    ppr = pprPat noPrec
-
-pprPat :: Precedence -> Pat -> Doc
-pprPat i (LitP l)     = pprLit i l
-pprPat _ (VarP v)     = ppr v
-pprPat _ (TupP ps)    = parens $ sep $ punctuate comma $ map ppr ps
-pprPat i (ConP s ps)  = parensIf (i > noPrec) $ x
-                                            <+> sep (map (pprPat appPrec) ps)
-    where
-      x | isTupleT (ConT s) = text (nameBase s)
-        | s == '[]          = text "[]"
-        | s == '(:)         = text "(:)"
-        | otherwise         = ppr s
-
-pprPat i (InfixP p1 n p2)
-                      = parensIf (i > noPrec)
-                      $ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2
-pprPat i (TildeP p)   = parensIf (i > noPrec) $ text "~" <> pprPat appPrec p
-pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"
-                                                      <> pprPat appPrec p
-pprPat _ WildP        = text "_"
-pprPat _ (RecP nm fs)
- = parens $     ppr nm
-            <+> braces (sep $ punctuate comma $
-                        map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
-pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps
-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t
-
-------------------------------
-instance Ppr Dec where
-    ppr (FunD f cs)   = vcat $ map (\c -> ppr f <+> ppr c) cs
-    ppr (ValD p r ds) = ppr p <+> pprBody True r
-                     $$ where_clause ds
-    ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) 
-                        <+> text "=" <+> ppr rhs
-    ppr (DataD ctxt t xs cs decs)
-        = text "data"
-      <+> pprCxt ctxt
-      <+> ppr t <+> hsep (map ppr xs)
-      <+> sep (pref $ map ppr cs)
-       $$ if null decs
-          then empty
-          else nest nestDepth
-             $ text "deriving"
-           <+> parens (hsep $ punctuate comma $ map ppr decs)
-        where pref :: [Doc] -> [Doc]
-              pref [] = [] -- Can't happen in H98
-              pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
-    ppr (NewtypeD ctxt t xs c decs)
-        = text "newtype"
-      <+> pprCxt ctxt
-      <+> ppr t <+> hsep (map ppr xs)
-      <+> char '=' <+> ppr c
-       $$ if null decs
-          then empty
-          else nest nestDepth
-             $ text "deriving"
-           <+> parens (hsep $ punctuate comma $ map ppr decs)
-    ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt
-                                <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
-                                 $$ where_clause ds
-    ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
-                             $$ where_clause (map deQualLhsHead ds)
-    ppr (SigD f t) = ppr f <+> text "::" <+> ppr t
-    ppr (ForeignD f) = ppr f
-                       
-deQualLhsHead :: Dec -> Dec
-deQualLhsHead (FunD n cs) = FunD (deQualName n) cs
-deQualLhsHead (ValD p b ds) = ValD (go p) b ds
-    where
-      go (VarP n) = VarP (deQualName n)
-      go (InfixP p1 n p2) = InfixP p1 (deQualName n) p2
-      go x = x
-deQualLhsHead x = x
-                  
-deQualName :: Name -> Name
-deQualName = mkName . nameBase
-
-------------------------------
-instance Ppr FunDep where
-    ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
-    ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))
-
-------------------------------
-instance Ppr Foreign where
-    ppr (ImportF callconv safety impent as typ)
-       = text "foreign import"
-     <+> showtextl callconv
-     <+> showtextl safety
-     <+> text (show impent)
-     <+> ppr as
-     <+> text "::" <+> ppr typ
-    ppr (ExportF callconv expent as typ)
-        = text "foreign export"
-      <+> showtextl callconv
-      <+> text (show expent)
-      <+> ppr as
-      <+> text "::" <+> ppr typ
-
-------------------------------
-instance Ppr Clause where
-    ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
-                             $$ where_clause ds
-
-------------------------------
-instance Ppr Con where
-    ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
-    ppr (RecC c vsts)
-        = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
-    ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName_ False c <+> pprStrictType st2
-    ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)
-                            <+> char '.' <+> pprCxt ctxt <+> ppr con
-
-------------------------------
-pprVarStrictType :: (Name, Strict, Type) -> Doc
--- Slight infelicity: with print non-atomic type with parens
-pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)
-
-------------------------------
-pprStrictType :: (Strict, Type) -> Doc
--- Prints with parens if not already atomic
-pprStrictType (IsStrict, t) = char '!' <> pprParendType t
-pprStrictType (NotStrict, t) = pprParendType t
-
-------------------------------
-pprParendType :: Type -> Doc
-pprParendType (VarT v)   = ppr v
-pprParendType (ConT c) 
-     | c == ''[]         = pprParendType ListT
-     | c == ''(->)        = pprParendType ArrowT
-     | isTupleT (ConT c) = pprParendType (TupleT (length (nameBase c) - 1))
-     | otherwise         = ppr c
-pprParendType (TupleT 0) = text "()"
-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
-pprParendType ArrowT     = parens (text "->")
-pprParendType ListT      = text "[]"
-pprParendType other      = parens (ppr other)
-
-instance Ppr Type where
-    ppr (ForallT tvars ctxt ty) = 
-        text "forall" <+> hsep (map ppr tvars) <+> text "."
-                      <+> pprCxt ctxt <+> ppr ty
-#if __GLASGOW_HASKELL__ >= 706
-    ppr StarT = text "*"
-#endif
-    ppr ty = pprTyApp (split ty)
-
-pprTyApp :: (Type, [Type]) -> Doc
-pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2]
-pprTyApp (ListT, [arg]) = brackets (ppr arg)
-pprTyApp (TupleT n, args)
- | length args == n = parens (sep (punctuate comma (map ppr args)))
-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
-
-split :: Type -> (Type, [Type])    -- Split into function and args
-split t = go t []
-    where go (AppT t1 t2) args = go t1 (t2:args)
-          go ty           args = (ty, args)
-
-------------------------------
-pprCxt :: Cxt -> Doc
-pprCxt [] = empty
-pprCxt [t] = ppr t <+> text "=>"
-pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"
-
-------------------------------
-instance Ppr Range where
-    ppr = brackets . pprRange
-        where pprRange :: Range -> Doc
-              pprRange (FromR e) = ppr e <> text ".."
-              pprRange (FromThenR e1 e2) = ppr e1 <> text ","
-                                        <> ppr e2 <> text ".."
-              pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
-              pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
-                                             <> ppr e2 <> text ".."
-                                             <> ppr e3
-
-------------------------------
-where_clause :: [Dec] -> Doc
-where_clause [] = empty
-where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)
-
-showtextl :: Show a => a -> Doc
-showtextl = text . map toLower . show
-
-
-#if __GLASGOW_HASKELL__ >= 612
-
-instance Ppr TyVarBndr where
-    ppr (PlainTV v) = ppr v
-    ppr (KindedTV v k) = parens $ ppr v <+> text "::" <+> ppr k
-
-#if __GLASGOW_HASKELL__ < 706
-instance Ppr Kind where
-    ppr StarK = text "*"
-    ppr (ArrowK j k) = ppr j <+> text "->" <+> ppr k
-#endif
-
-#if __GLASGOW_HASKELL__ < 709
-instance Ppr Pred where
-    ppr (ClassP n ts) = ppr n <+> hsep (map ppr ts)
-    ppr (EqualP t u ) = ppr t <+> text "~" <+> ppr u
-#endif
-
-#endif
diff --git a/Language/Haskell/TH/Helper.hs b/Language/Haskell/TH/Helper.hs
deleted file mode 100644
--- a/Language/Haskell/TH/Helper.hs
+++ /dev/null
@@ -1,248 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-
-
--- | These small short-named functions are intended to make the
---   construction of abstranct syntax trees less tedious.
-module Language.Haskell.TH.Helper where
-
-import Data.Char
-
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Data
-import Language.Haskell.TH.Compat
-
-
-
--- * Special folds for the guessing
-
-
-applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp
-applyWith  join xs = foldl  AppE join                      xs
-foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs
-foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs
-
-
-
--- * Syntax elements
---
-
--- | A simple clause, without where or guards.
-sclause :: [Pat] -> Exp -> Clause
-sclause pats body = Clause pats (NormalB body) []
-
--- | A default clause with N arguments.
-defclause :: Int -> Exp -> Clause
-defclause num = sclause (replicate num WildP)
-
--- | A simple Val clause
-sval :: Pat -> Exp -> Dec
-sval pat body = ValD pat (NormalB body) []
-
-
-case' :: Exp -> [(Pat, Exp)] -> Exp
-case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ]
-
-(->:) :: String -> Exp -> Exp
-(->:) nm bdy = LamE [vr nm] bdy
-
--- | We provide 3 standard instance constructors
---   instance_default requires C for each free type variable
---   instance_none requires no context
---   instance_context requires a given context
-instance_none :: String -> DataDef -> [Dec] -> Dec
-instance_none = instance_context []
-
-instance_default :: String -> DataDef -> [Dec] -> Dec
-instance_default n = instance_context [n] n
-
-instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec
-instance_context req cls dat defs = InstanceD ctx hed defs
-    where
-        vrs = vars 't' (dataArity dat)
-        hed = l1 cls (lK (dataName dat) vrs)
-        ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]
-
-
--- | Build an instance of a class for a data type, using the heuristic
--- that the type is itself required on all type arguments.
-simple_instance :: String -> DataDef -> [Dec] -> [Dec]
-simple_instance cls dat defs = [instance_default cls dat defs]
-
--- | Build an instance of a class for a data type, using the class at the given types
-generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec]
-generic_instance cls dat ctxTypes defs = [InstanceD ctx hed defs]
-    where
-        vrs = vars 't' (dataArity dat)
-        hed = l1 cls (lK (dataName dat) vrs)
-        ctx = map (typeToPred . l1 cls) ctxTypes
-
--- | Build a type signature declaration with a string name
-sigN :: String -> Type -> Dec
-sigN nam ty = SigD (mkName nam) ty
-
--- | Build a fundecl with a string name
-funN :: String -> [Clause] -> Dec
-funN nam claus = FunD (mkName nam) claus
-
--- * Pattern vs Value abstraction
-
-class Eq nm => NameLike nm where
-  toName :: nm -> Name
-instance NameLike Name   where toName = id
-instance NameLike String where toName = mkName
-
--- | The class used to overload lifting operations.  To reduce code
--- duplication, we overload the wrapped constructors (and everything
--- else, but that's irrelevant) to work in patterns, expressions, and
--- types.
-class Valcon a where
-      -- | Build an application node, with a name for a head and a
-      -- provided list of arguments.
-      lK :: NameLike nm => nm -> [a] -> a
-      -- | Reference a named variable.
-      vr :: NameLike nm => nm -> a
-      -- | Lift a TH 'Lit'
-      raw_lit :: Lit -> a
-      -- | Tupling
-      tup :: [a] -> a
-      -- | Listing
-      lst :: [a] -> a
-instance Valcon Exp where
-      lK nm ys = let name = toName nm in case (nameBase name, ys) of
-        ("[]", []) -> ConE name
-        ("[]", xs) -> lst xs
-        ((x:_), args)  | isUpper x || x == ':' -> foldl AppE (ConE name) args
-        ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b)
-         where isOper x = not (isAlpha x || x == '_')
-        (nm,     args) -> foldl AppE (VarE name) args
-
-      vr = VarE . toName
-      raw_lit = LitE
-      tup = TupE
-      lst = ListE
-instance Valcon Pat where
-      lK = ConP . toName
-      vr = VarP . toName
-      raw_lit = LitP
-      tup = TupP
-      lst = ListP
-instance Valcon Type where
-      lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))
-        where bNm = nameBase (toName nm)
-      vr = VarT . toName
-      raw_lit = error "raw_lit @ Type"
-
-      -- XXX work around bug in GHC < 6.10
-      -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)
-      tup [t] = t
-      tup ts  = foldl AppT (TupleT (length ts)) ts
-
-      lst = error "lst @ Type"
-
--- | Build an application node without a given head
-app :: Exp -> [Exp] -> Exp
-app root args = foldl AppE root args
-
-
--- | This class is used to overload literal construction based on the
--- type of the literal.
-class LitC a where
-      lit :: Valcon p => a -> p
-instance LitC Integer where
-      lit = raw_lit . IntegerL
-instance LitC Char where
-      lit = raw_lit . CharL
-instance LitC a => LitC [a] where
-      lit = lst . map lit
-instance (LitC a, LitC b) => LitC (a,b) where
-      lit (x,y) = tup [lit x, lit y]
-instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where
-      lit (x,y,z) = tup [lit x, lit y, lit z]
-instance LitC () where
-      lit () = tup []
-
-
--- * Constructor abstraction
-
-dataVars :: DataDef -> [Type]
-dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..]
-
--- | Common pattern: list of a familiy of variables
-vars :: Valcon a => Char -> Int -> [a]
-vars c n = map (vrn c) [1 .. n]
-
--- | Variable based on a letter + number
-vrn :: Valcon a => Char -> Int -> a
-vrn c n = vr (c : show n)
-
--- | Make a list of variables, one for each argument to a constructor
-ctv :: Valcon a => CtorDef -> Char -> [a]
-ctv ctor c = vars c (ctorArity ctor)
-
--- | Make a simple pattern to bind a constructor
-ctp :: Valcon a => CtorDef -> Char -> a
-ctp ctor c = lK (ctorName ctor) (ctv ctor c)
-
--- | Reference the constructor itself
-ctc :: Valcon a => CtorDef -> a
-ctc = l0 . ctorName
-
-
--- * Lift a constructor over a fixed number of arguments.
-
-l0 :: (NameLike nm, Valcon a) => nm -> a
-l1 :: (NameLike nm, Valcon a) => nm -> a -> a
-l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a
-l0 s     = lK s []
-l1 s a   = lK s [a]
-l2 s a b = lK s [a,b]
-
--- * Pre-lifted versions of common operations
-true, false, nil :: Valcon a => a
-hNil', hZero' :: Type
-true = l0 "True"
-false = l0 "False"
-nil = l0 "[]"
-unit = lit ()
-hNil' = l0 "HNil"
-hZero' = l0 "HZero"
-id' = l0 "id"
-
-cons :: Valcon a => a -> a -> a
-cons = l2 ":"
-
-box :: Valcon a => a -> a
-return', const' :: Exp -> Exp
-hSucc' :: Type -> Type
-box x = cons x nil
-return' = l1 "return"
-const' = l1 "const"
-hSucc' = l1 "HSucc"
-
-(==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp
-hCons' :: Type -> Type -> Type
-(==:) = l2 "=="
-(&&:) = l2 "&&"
-(++:) = l2 "++"
-(>>=:) = l2 ">>="
-(>>:) = l2 ">>"
-(.:) = l2 "."
-(>:) = l2 ">"
-ap' = l2 "ap"
-hCons' = l2 "HCons"
-
--- | Build a chain of expressions, with an appropriate terminal
---   sequence__ does not require a unit at the end (all others are optimised automatically)
-(&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp
-(&&::)  = foldr (&&:) true
-(++::) = foldr (++:) nil
-(>>::) = foldr (>>:) (return' unit)
-(.::) = foldr (.:) id'
-
-sequence__ [] = return' unit
-sequence__ xs = foldr1 (>>:) xs
-
-
--- | K-way liftM
-liftmk :: Exp -> [Exp] -> Exp
-liftmk hd args = foldl ap' (return' hd) args
diff --git a/Language/Haskell/TH/Peephole.hs b/Language/Haskell/TH/Peephole.hs
deleted file mode 100644
--- a/Language/Haskell/TH/Peephole.hs
+++ /dev/null
@@ -1,202 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-
-module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where
-
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Helper
-import Data.Generics
-import Data.Maybe
-import Data.List
-import Debug.Trace
-
-traceMode = False
-
-
-peephole :: Data a => a -> a
-peephole = everywhere (mkT peep) . everywhere (mkT peepPat)
-
-
-
--- find a given string, and replace it with a particular expression
--- must succeed, so crashes readily (deliberately!)
-replaceVars :: [(Name,Exp)] -> Exp -> Exp
-replaceVars rep orig = fExp orig
-    where
-        fExp x = case x of
-            VarE y -> fromMaybe x $ lookup y rep
-            ConE _ -> x
-            LitE _ -> x
-            AppE x y -> AppE (fExp x) (fExp y)
-            CaseE x y -> CaseE (fExp x) (map fMatch y)
-            TupE xs -> TupE (map fExp xs)
-            ListE xs -> ListE (map fExp xs)
-            LamE x y -> LamE x (fPat x y)
-            _ | null $ map fst rep `intersect` getNames x -> x
-            _ -> error $ "replaceVar: " ++ show x
-
-        getNames x = everything (++) ([] `mkQ` f) x
-            where
-                f :: Name -> [Name]
-                f x = [x]
-
-        fMatch o@(Match pat (NormalB bod) []) =
-            Match pat (NormalB $ fPat [pat] bod) []
-
-        -- given these pattern have come into scope
-        -- continue matching on the rest
-        fPat :: [Pat] -> Exp -> Exp
-        fPat pat = replaceVars (filter ((`notElem` used) . fst) rep)
-            where used = concatMap usedPats pat
-
-        usedPats x = everything (++) ([] `mkQ` f) x
-            where
-                f (VarP x) = [x]
-                f _ = []
-
-
-replaceVar :: Name -> Exp -> Exp -> Exp
-replaceVar name with = replaceVars [(name,with)]
-
-
-
--- based on the rewrite combinator in Play
-peep :: Exp -> Exp
-peep (ListE xs)
-    | not (null xs) && all (isJust . fromLitChar) xs =
-      peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs
-    where
-        fromLitChar (LitE (CharL x)) = Just x
-        fromLitChar _ = Nothing
-
-peep (AppE x y)
-    | x ~= "id" = y
-
-peep (AppE (AppE op x) y)
-    | Just res <- peepBin op x y = res
-
-peep (InfixE (Just x) op (Just y))
-    | Just res <- peepBin op x y = res
-
-peep (LamE [] x) = x
-
-peep (LamE [VarP x] (VarE y))
-    | x == y = l0 "id"
-
-peep (DoE [NoBindS x]) = x
-
-peep x@(ConE _)
-    | x ~= "[]" = ListE []
-
-peep (AppE (AppE cons x) nil)
-    | cons ~= ":" && nil ~= "[]" = ListE [x]
-
-peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e])
-    | ret ~= "return" = peep $ replaceVar p (LitE val) e
-
-peep (LamE [TupP [VarP x, VarP y]] (VarE z))
-    | x == z = l0 "fst"
-    | y == z = l0 "snd"
-
-peep (AppE (LamE (VarP x:xs) y) z)
-    | simple z
-    = peep $ LamE xs (replaceVar x z y)
-
-peep (AppE (AppE bind (AppE ret x)) y)
-    | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x
-
-peep (InfixE (Just (AppE ret x)) bind (Just y))
-    | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x
-
-peep (InfixE (Just (AppE pure x)) ap y)
-    | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y
-
-peep (InfixE (Just x) fmap (Just (AppE pure y)))
-    | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)
-
-peep (AppE append (ListE [x]))
-    | append ~= "++" = peep $ AppE (l0 ":") x
-
-peep (InfixE (Just (ListE [x])) append y)
-    | append ~= "++" = peep $ InfixE (Just x) (l0 ":") y
-
-peep (InfixE (Just x) cons (Just (ListE xs)))
-    | cons ~= ":" = peep $ ListE (x:xs)
-
-peep (AppE (AppE (AppE comp f) g) x)
-    | comp ~= "."  = peep $ AppE f (peep $ AppE g x)
-peep (AppE (InfixE (Just f) comp (Just g)) x)
-    | comp ~= "."  = peep $ AppE f (peep $ AppE g x)
-
-peep (AppE (AppE (AppE flip f) x) y)
-    | flip ~= "flip"  = peep $ AppE (AppE f y) x
-
-peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)
-peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)
-
-peep (AppE f (LamE x (ListE [y])))
-    | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y)
-
-peep (AppE f (ListE xs))
-    | f ~= "head" && not (null xs) = head xs
-    | f ~= "reverse" = ListE $ reverse xs
-
-peep (AppE f (TupE [x,y]))
-    | f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x
-
-peep (AppE (AppE sq o@(AppE rnf x)) (TupE []))
-    | sq ~= "seq" && rnf ~= "rnf" = o
-
-peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))
-    | x == y = z
-
-peep (AppE len (ListE xs))
-    | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs
-
-peep (TupE [x]) = x
-
-peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]
-
-peep (AppE (CaseE e [Match p (NormalB x) []]) y)
-       = CaseE e [Match p (NormalB $ peep $ AppE x y) []]
-
--- allow easy flip to tracing mode
-peep x | traceMode = trace (show x) x
-peep x = x
-
-
-peepPat :: Pat -> Pat
-peepPat (ListP xs)
-    | all (\x -> case x of LitP (CharL _) -> True
-                           _ -> False) xs =
-      LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs
-
-peepPat x = x
-
-peepBin :: Exp -> Exp -> Exp -> Maybe Exp
-peepBin op x y
-    | op ~= "." && x ~= "id" = Just y
-    | op ~= "." && y ~= "id" = Just x
-    | op ~= "&&" && y ~= "True" = Just x
-    | op ~= "const" = Just x
-    | op ~= "map" && x ~= "id" = Just y
-    | op ~= "++" && x ~= "[]" = Just y
-    | op ~= "++" && y ~= "[]" = Just x
-    | op ~= "." && y ~= "id" = Just x
-    | op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id"
-    | op ~= "$" = Just $ peep $ AppE x y
-
-peepBin op (LitE (StringL x)) (LitE (StringL y))
-    | op ~= "++" = Just $ LitE $ StringL (x++y)
-
-peepBin _ _ _ = Nothing
-
-
-(VarE f) ~= x = show f == x
-(ConE f) ~= x = show f == x
-(ListE []) ~= "[]" = True
-_ ~= _ = False
-
-
-simple (VarE _) = True
-simple (LitE _) = True
-simple _ = False
diff --git a/derive.cabal b/derive.cabal
--- a/derive.cabal
+++ b/derive.cabal
@@ -1,9 +1,9 @@
-cabal-version:  >= 1.6
+cabal-version:  >= 1.8
 build-type:     Default
 name:           derive
-version:        2.5.23
+version:        2.5.24
 build-type:     Simple
-copyright:      Neil Mitchell 2006-2015
+copyright:      Neil Mitchell 2006-2016
 author:         Neil Mitchell <ndmitchell@gmail.com>
 maintainer:     Neil Mitchell <ndmitchell@gmail.com>
 homepage:       https://github.com/ndmitchell/derive#readme
@@ -20,16 +20,18 @@
 extra-doc-files:
     README.md
     CHANGES.txt
-tested-with:        GHC==7.10.1, GHC==7.8.4, GHC==7.6.3
+tested-with:        GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3
 
 source-repository head
     type:     git
     location: https://github.com/ndmitchell/derive.git
 
 executable derive
+    build-depends: base==4.* , derive
     main-is: Main.hs
 
 library
+    hs-source-dirs: src
     build-depends:
         base == 4.*,
         filepath, syb, template-haskell, containers, pretty,
@@ -57,7 +59,6 @@
         Language.Haskell.TH.Compat
         Language.Haskell.TH.Data
         Language.Haskell.TH.ExpandSynonym
-        Language.Haskell.TH.FixedPpr
         Language.Haskell.TH.Helper
         Language.Haskell.TH.Peephole
 -- GENERATED START
diff --git a/src/Data/Derive/All.hs b/src/Data/Derive/All.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/All.hs
@@ -0,0 +1,45 @@
+-- | This module provides convenience re-exports of all the standard
+-- Data.Derive derivations.
+module Data.Derive.All (Derivation, derivations, module D) where
+
+import Data.Derive.Internal.Derivation
+
+-- GENERATED START
+import Data.Derive.Arbitrary           as D
+import Data.Derive.ArbitraryOld        as D
+import Data.Derive.Arities             as D
+import Data.Derive.Binary              as D
+import Data.Derive.BinaryDefer         as D
+import Data.Derive.Bounded             as D
+import Data.Derive.Data                as D
+import Data.Derive.DataAbstract        as D
+import Data.Derive.Default             as D
+import Data.Derive.Enum                as D
+import Data.Derive.EnumCyclic          as D
+import Data.Derive.Eq                  as D
+import Data.Derive.Fold                as D
+import Data.Derive.Foldable            as D
+import Data.Derive.From                as D
+import Data.Derive.Functor             as D
+import Data.Derive.Has                 as D
+import Data.Derive.Is                  as D
+import Data.Derive.JSON                as D
+import Data.Derive.LazySet             as D
+import Data.Derive.Lens                as D
+import Data.Derive.Monoid              as D
+import Data.Derive.NFData              as D
+import Data.Derive.Ord                 as D
+import Data.Derive.Read                as D
+import Data.Derive.Ref                 as D
+import Data.Derive.Serial              as D
+import Data.Derive.Serialize           as D
+import Data.Derive.Set                 as D
+import Data.Derive.Show                as D
+import Data.Derive.Traversable         as D
+import Data.Derive.Typeable            as D
+import Data.Derive.UniplateDirect      as D
+import Data.Derive.UniplateTypeable    as D
+import Data.Derive.Update              as D
+derivations :: [Derivation]
+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSerialize,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Arbitrary.hs b/src/Data/Derive/Arbitrary.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Arbitrary.hs
@@ -0,0 +1,83 @@
+module Data.Derive.Arbitrary(makeArbitrary) where
+{-
+import "QuickCheck" Test.QuickCheck
+
+example :: Custom
+
+instance Arbitrary (Sample a) where
+    arbitrary = do
+        x <- choose (0::Int,length [First{},Second{},Third{}] - 1)
+        case x of
+            0 -> do return (First)
+            1 -> do x1 <- arbitrary
+                    x2 <- arbitrary
+                    return (Second x1 x2)
+            2 -> do x1 <- arbitrary
+                    return (Third x1)
+            _ -> error "FATAL ERROR: Arbitrary instance, logic bug"
+
+test :: State
+instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where
+    arbitrary = do x1 <- arbitrary
+                   return (StateT x1)
+-}
+
+import Data.Derive.DSL.HSE
+import Data.List
+import Data.Generics.Uniplate.DataOnly
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeArbitrary :: Derivation
+makeArbitrary = derivationCustomDSL "Arbitrary" custom $
+    List [Instance [] "Arbitrary" (List [App "InsDecl" (List [App
+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [List [
+    App "Generator" (List [App "PVar" (List [App "Ident" (List [String
+    "x"])]),App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "choose"])])]),App "Tuple" (List [App
+    "Boxed" (List []),List [App "ExpTypeSig" (List [App "Lit" (List [
+    App "Int" (List [Int 0])]),App "TyCon" (List [App "UnQual" (List [
+    App "Ident" (List [String "Int"])])])]),App "InfixApp" (List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "length"])])]),App "List" (List [MapCtor (App
+    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
+    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List
+    [Int 1])])])]])])]),App "Qualifier" (List [App "Case" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])])
+    ]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (List [App
+    "Signless" (List []),App "Int" (List [CtorIndex])]),App
+    "UnGuardedRhs" (List [App "Do" (List [Concat (List [MapField (App
+    "Generator" (List [App "PVar" (List [App "Ident" (List [Concat (
+    List [String "x",ShowInt FieldIndex])])]),App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "arbitrary"])])])])),
+    List [App "Qualifier" (List [App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "return"])])]),App
+    "Paren" (List [Application (Concat (List [List [App "Con" (List [
+    App "UnQual" (List [App "Ident" (List [CtorName])])])],MapField (
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
+    List [String "x",ShowInt FieldIndex])])])]))]))])])])]])])]),App
+    "Nothing" (List [])])),List [App "Alt" (List [App "PWildCard" (
+    List []),App "UnGuardedRhs" (List [App "App" (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "error"])])]),
+    App "Lit" (List [App "String" (List [String
+    "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "Nothing"
+    (List [])])]])])])]])]),App "Nothing" (List [])])])])]
+-- GENERATED STOP
+
+custom = customContext context
+
+-- Fix the context
+-- C a b => Arbitrary a, Arbitrary b
+-- a -> b => CoArbitrary a, Arbitrary b
+context :: FullDataDecl -> Context -> Context
+context (_,d) _ = nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d
+    where
+        f b (TyVar x) = [ClassA (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar x]]
+        f b (TyFun x y) = f (not b) x ++ f b y
+        f b x = concatMap (f b) (children x)
+
diff --git a/src/Data/Derive/ArbitraryOld.hs b/src/Data/Derive/ArbitraryOld.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/ArbitraryOld.hs
@@ -0,0 +1,74 @@
+module Data.Derive.ArbitraryOld where
+{-
+import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)
+
+example :: Sample
+
+instance Arbitrary a => Arbitrary (Sample a) where
+    arbitrary = do
+        x <- choose (0,length [First{},Second{},Third{}]-1)
+        case x of
+            0 -> do return (First)
+            1 -> do x1 <- arbitrary
+                    x2 <- arbitrary
+                    return (Second x1 x2)
+            2 -> do x1 <- arbitrary
+                    return (Third x1)
+
+    coarbitrary (First) = variant 0
+    coarbitrary (Second x1 x2) = variant 1 . coarbitrary x1 . coarbitrary x2
+    coarbitrary (Third x1) = variant 2 . coarbitrary x1
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeArbitraryOld :: Derivation
+makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld
+
+dslArbitraryOld =
+    List [Instance ["Arbitrary"] "Arbitrary" (List [App "InsDecl" (
+    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
+    String "arbitrary"])]),App "UnGuardedRhs" (List [App "Do" (List [
+    List [App "Generator" (List [App "PVar" (List [App "Ident" (List [
+    String "x"])]),App "App" (List [App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "choose"])])]),App "Tuple" (List [
+    App "Boxed" (List []),List [App "Lit" (List [App "Int" (List [Int
+    0])]),App "InfixApp" (List [App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "length"])])]),App
+    "List" (List [MapCtor (App "RecConstr" (List [App "UnQual" (List [
+    App "Ident" (List [CtorName])]),List []]))])]),App "QVarOp" (List
+    [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App
+    "Lit" (List [App "Int" (List [Int 1])])])]])])]),App "Qualifier" (
+    List [App "Case" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "x"])])]),MapCtor (App "Alt" (List [App
+    "PLit" (List [App "Signless" (List []),App "Int" (List [CtorIndex]
+    )]),App "UnGuardedRhs" (List [App "Do" (List [Concat (List [
+    MapField (App "Generator" (List [App "PVar" (List [App "Ident" (
+    List [Concat (List [String "x",ShowInt FieldIndex])])]),App "Var"
+    (List [App "UnQual" (List [App "Ident" (List [String "arbitrary"])
+    ])])])),List [App "Qualifier" (List [App "App" (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "return"])])])
+    ,App "Paren" (List [Application (Concat (List [List [App "Con" (
+    List [App "UnQual" (List [App "Ident" (List [CtorName])])])],
+    MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    Concat (List [String "x",ShowInt FieldIndex])])])]))]))])])])]])])
+    ]),App "Nothing" (List [])]))])])]])]),App "Nothing" (List [])])])
+    ,App "InsDecl" (List [App "FunBind" (List [MapCtor (App "Match" (
+    List [App "Ident" (List [String "coarbitrary"]),List [App "PParen"
+    (List [App "PApp" (List [App "UnQual" (List [App "Ident" (List [
+    CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat
+    (List [String "x",ShowInt FieldIndex])])]))])])],App "Nothing" (
+    List []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [
+    Head,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
+    String "."])])]),Tail])) (Concat (List [List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "variant"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])]
+    ,MapField (App "App" (List [App "Var" (List [App "UnQual" (List [
+    App "Ident" (List [String "coarbitrary"])])]),App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [Concat (List [String "x",
+    ShowInt FieldIndex])])])])]))]))]),App "Nothing" (List [])]))])])]
+    )]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Arities.hs b/src/Data/Derive/Arities.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Arities.hs
@@ -0,0 +1,44 @@
+module Data.Derive.Arities where
+{-
+import "derive" Data.Derive.Class.Arities
+
+example :: Sample
+
+instance Arities (Sample a) where
+    arities _ = [const 0 First{}, const 2 Second{}, const 1 Third{}]
+
+test :: []
+
+instance Arities [a] where
+    arities _ = [0,2]
+
+test :: Bool
+
+instance Arities Bool where
+    arities _ = [0,0]
+
+test :: Either
+
+instance Arities (Either a b) where
+    arities _ = [1,1]
+-}
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeArities :: Derivation
+makeArities = derivationDSL "Arities" dslArities
+
+dslArities =
+    List [Instance [] "Arities" (List [App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "arities"]),List [App "PWildCard" (List [])],App "Nothing"
+    (List []),App "UnGuardedRhs" (List [App "List" (List [MapCtor (
+    Application (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "const"])])]),App "Lit" (List [App "Int" (
+    List [CtorArity])]),App "RecConstr" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])]),List []])]))])]),App "Nothing" (List [
+    ])])]])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Binary.hs b/src/Data/Derive/Binary.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Binary.hs
@@ -0,0 +1,134 @@
+module Data.Derive.Binary where
+{-
+import "binary" Data.Binary
+
+example :: Sample
+
+instance Binary alpha => Binary (Sample alpha) where
+    put x = case x of
+        First          -> do putTag 0
+        Second  x1 x2  -> do putTag 1 ; put x1 ; put x2
+        Third   x1     -> do putTag 2 ; put x1
+        where
+            useTag = length [First{}, Second{}, Third{}] > 1
+            putTag x = when useTag (putWord8 x)
+
+    get = do
+        i <- getTag
+        case i of
+            0 -> do return (First)
+            1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)
+            2 -> do x1 <- get ; return (Third x1)
+            _ -> error "Corrupted binary data for Sample"
+        where
+            useTag = length [First{}, Second{}, Third{}] > 1
+            getTag = if useTag then getWord8 else return 0
+
+
+test :: List
+
+instance Binary a => Binary (List a) where
+    put x = case x of
+        Nil -> putWord8 0
+        Cons x1 x2 -> do putWord8 1; put x1; put x2
+
+    get = do
+        i <- getWord8
+        case i of
+            0 -> return Nil
+            1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)
+            _ -> error "Corrupted binary data for List"
+
+test :: Assoced
+
+instance Binary typ => Binary (Assoced typ) where
+    put (Assoced x1 x2) = do put x1; put x2
+    get = do x1 <- get; x2 <- get; return (Assoced x1 x2)
+
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeBinary :: Derivation
+makeBinary = derivationDSL "Binary" dslBinary
+
+dslBinary =
+    List [Instance ["Binary"] "Binary" (List [App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "put"]),List [App "PVar" (List [App "Ident" (List [String
+    "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
+    "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List
+    [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])]))]),App "UnGuardedRhs" (List [App "Do" (List [
+    Concat (List [List [App "Qualifier" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])
+    ],MapField (App "Qualifier" (List [App "App" (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "put"])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
+    List [String "x",ShowInt FieldIndex])])])])])]))])])]),App
+    "Nothing" (List [])]))])]),App "Just" (List [App "BDecls" (List [
+    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
+    String "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List
+    [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "length"])])]),App "List" (List [MapCtor (App
+    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
+    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
+    [Int 1])])])]),App "Nothing" (List [])]),App "FunBind" (List [List
+    [App "Match" (List [App "Ident" (List [String "putTag"]),List [App
+    "PVar" (List [App "Ident" (List [String "x"])])],App "Nothing" (
+    List []),App "UnGuardedRhs" (List [Application (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "when"])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "useTag"])])]),App "Paren" (List [App "App" (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [Concat (List [String
+    "putWord",ShowInt (Int 8)])])])]),App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "x"])])])])])])]),App "Nothing" (
+    List [])])]])]])])])]])]),App "InsDecl" (List [App "PatBind" (List
+    [App "PVar" (List [App "Ident" (List [String "get"])]),App
+    "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List
+    [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "getTag"])])])
+    ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [
+    MapCtor (App "Alt" (List [App "PLit" (List [App "Signless" (List [
+    ]),App "Int" (List [CtorIndex])]),App "UnGuardedRhs" (List [App
+    "Do" (List [Concat (List [MapField (App "Generator" (List [App
+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])]),App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "get"])])])])),List [App "Qualifier" (List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "return"])])]),App "Paren" (List [Application (Concat
+    (List [List [App "Con" (List [App "UnQual" (List [App "Ident" (
+    List [CtorName])])])],MapField (App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [])])),
+    List [App "Alt" (List [App "PWildCard" (List []),App
+    "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"
+    (List [App "String" (List [Concat (List [String
+    "Corrupted binary data for ",DataName])])])])]),App "Nothing" (
+    List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [List
+    [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "length"])])]),App "List" (List [MapCtor (App
+    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
+    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
+    [Int 1])])])]),App "Nothing" (List [])]),App "PatBind" (List [App
+    "PVar" (List [App "Ident" (List [String "getTag"])]),App
+    "UnGuardedRhs" (List [App "If" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "useTag"])])]),App "Var"
+    (List [App "UnQual" (List [App "Ident" (List [Concat (List [String
+    "getWord",ShowInt (Int 8)])])])]),App "App" (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [String "return"])])]),App
+    "Lit" (List [App "Int" (List [Int 0])])])])]),App "Nothing" (List
+    [])])]])])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/BinaryDefer.hs b/src/Data/Derive/BinaryDefer.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/BinaryDefer.hs
@@ -0,0 +1,63 @@
+module Data.Derive.BinaryDefer where
+{-
+import "binarydefer" Data.Binary.Defer
+
+example :: Sample
+
+instance BinaryDefer a => BinaryDefer (Sample a) where
+    bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) <<! o else unit First
+                      ,\ ~(o@(Second x1 x2)) -> if null [const () x1, const () x2] then unit (Second x1 x2) <<! o else unit Second << x1 << x2
+                      ,\ ~(o@(Third x1)) -> if null [const () x1] then unit (Third x1) <<! o else unit Third << x1
+                      ]
+
+test :: FailList
+
+instance (BinaryDefer e, BinaryDefer a) => BinaryDefer (FailList e a) where
+    bothDefer = defer [\ ~(o@Zoro) -> unit Zoro <<! o
+                      ,\ ~(Fial x1) -> unit Fial << x1
+                      ,\ ~(Const x1 x2) -> unit Const << x1 << x2
+                      ]
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeBinaryDefer :: Derivation
+makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer
+
+dslBinaryDefer =
+    List [Instance ["BinaryDefer"] "BinaryDefer" (List [App "InsDecl"
+    (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
+    String "bothDefer"])]),App "UnGuardedRhs" (List [App "App" (List [
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "defer"])])]),App "List" (List [MapCtor (App "Lambda" (List [List
+    [App "PIrrPat" (List [App "PParen" (List [App "PAsPat" (List [App
+    "Ident" (List [String "o"]),App "PParen" (List [App "PApp" (List [
+    App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])]))])])])])])],App "If" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "null"]
+    )])]),App "List" (List [MapField (Application (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "const"])])]),
+    App "Con" (List [App "Special" (List [App "UnitCon" (List [])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
+    List [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp"
+    (List [App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "unit"])])]),App "Paren" (List [Application
+    (Concat (List [List [App "Con" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])])])],MapField (App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [Concat (List [String "x",
+    ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (List [App
+    "UnQual" (List [App "Symbol" (List [String "<<!"])])]),App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "o"])])])]),
+    Fold (App "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual"
+    (List [App "Symbol" (List [String "<<"])])]),Head])) (Concat (List
+    [Reverse (MapField (App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])])])
+    )),List [App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "unit"])])]),App "Con" (List [App "UnQual" (
+    List [App "Ident" (List [CtorName])])])])]]))])]))])])]),App
+    "Nothing" (List [])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Bounded.hs b/src/Data/Derive/Bounded.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Bounded.hs
@@ -0,0 +1,42 @@
+module Data.Derive.Bounded where
+{-
+import Prelude
+
+example :: Sample
+
+instance Bounded a => Bounded (Sample a) where
+    minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]
+    maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First]
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeBounded :: Derivation
+makeBounded = derivationDSL "Bounded" dslBounded
+
+dslBounded =
+    List [Instance ["Bounded"] "Bounded" (List [App "InsDecl" (List [
+    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "minBound"])]),App "UnGuardedRhs" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "head"]
+    )])]),App "List" (List [MapCtor (Application (Concat (List [List [
+    App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])
+    ])])],MapField (App "Paren" (List [Application (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "const"])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "minBound"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])]
+    )]))])))])])]),App "Nothing" (List [])])]),App "InsDecl" (List [
+    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "maxBound"])]),App "UnGuardedRhs" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "head"]
+    )])]),App "List" (List [Reverse (MapCtor (Application (Concat (
+    List [List [App "Con" (List [App "UnQual" (List [App "Ident" (List
+    [CtorName])])])],MapField (App "Paren" (List [Application (List [
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "const"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "maxBound"])])]),App "Lit" (List [App "Int" (List [
+    FieldIndex])])])]))]))))])])]),App "Nothing" (List [])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Class/Arities.hs b/src/Data/Derive/Class/Arities.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Class/Arities.hs
@@ -0,0 +1,5 @@
+
+module Data.Derive.Class.Arities where
+
+class Arities a where
+    arities :: a -> [Int]
diff --git a/src/Data/Derive/Class/Default.hs b/src/Data/Derive/Class/Default.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Class/Default.hs
@@ -0,0 +1,5 @@
+
+module Data.Derive.Class.Default where
+
+class Default a where
+    def :: a
diff --git a/src/Data/Derive/DSL/Apply.hs b/src/Data/Derive/DSL/Apply.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/DSL/Apply.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
+
+module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where
+
+import Data.Derive.DSL.HSE
+import Data.Derive.DSL.DSL
+import Data.List
+import Data.Generics.Uniplate.DataOnly
+
+
+apply :: DSL -> Input -> Out
+apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}
+
+
+env = Env
+    (error "Env.envInput: uninitialised")
+    (error "Env.envCtor: uninitialised")
+    (error "Env.envField: uninitialised")
+    (error "Env.envFold: uninitialised")
+
+
+data Env = Env  {envInput :: Input
+                ,envCtor :: Ctor
+                ,envField :: Integer
+                ,envFold :: (Output,Output) }
+
+applyEnv :: DSL -> Env -> Output
+applyEnv dsl env@(Env input ctor field fold) = f dsl
+    where
+    f (Instance ctx hd body) =
+        OApp "InstDecl"
+            [out (Nothing :: Maybe Overlap)
+            ,out ([] :: [TyVarBind])
+            ,out
+                [ClassA (UnQual $ Ident c) [TyVar $ Ident v]
+                | let seen = [x | TyVar (Ident x) <- universeBi $ concatMap ctorDeclFields $ dataCtors input]
+                , v <- dataDeclVarsStar input `intersect` seen
+                , c <- ctx]
+            ,out $ UnQual $ Ident hd
+            ,out [TyParen $ foldl TyApp
+                (TyCon $ UnQual $ Ident $ dataName input)
+                (map tyVar $ dataDeclVars input)]
+            ,f body]
+
+    f (Application (f -> OList xs)) =
+        foldl1 (\a b -> OApp "App" [a,b]) xs
+
+    f (MapCtor dsl) = OList  [applyEnv dsl env{envCtor=c}
+         |  c <- dataCtors input]
+    f (MapField dsl) = OList [applyEnv dsl env{envField=i}
+         | i <- [1.. fromIntegral $ ctorArity ctor]]
+
+    f DataName = OString $ dataName input
+    f CtorName = OString $ ctorName ctor
+    f CtorArity = OInt $ ctorArity ctor
+    f CtorIndex = OInt $ ctorIndex input ctor
+    f FieldIndex = OInt $ field
+
+    f Head = fst fold
+    f Tail = snd fold
+    f (Fold cons (f -> OList xs)) =
+        foldr1 (\a b -> applyEnv cons env{envFold=(a,b)}) xs
+
+    f (List xs) = OList $ map f xs
+    f (Reverse (f -> OList xs)) = OList $ reverse xs
+    f (Concat (f -> OList [])) = OList []
+    f (Concat (f -> OList xs)) = foldr1 g xs
+            where  g (OList    x) (OList    y) = OList    (x++y)
+                   g (OString  x) (OString  y) = OString  (x++y)
+    f (String x) = OString x
+    f (Int x) = OInt x
+    f (ShowInt (f -> OInt x)) = OString $ show x
+    f (App x (f -> OList ys)) = OApp x ys
diff --git a/src/Data/Derive/DSL/DSL.hs b/src/Data/Derive/DSL/DSL.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/DSL/DSL.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Data.Derive.DSL.DSL where
+
+import Data.Derive.DSL.HSE
+import Data.List
+import Data.Data
+import Data.Generics.Uniplate.DataOnly
+
+data DSL = App String DSL{-List-}
+         | Concat DSL
+         | Reverse DSL
+         | String String
+         | ShowInt DSL
+         | Int Integer
+         | List [DSL]
+         
+         | MapField DSL
+         | MapCtor DSL
+         | DataName
+         | CtorName
+         | CtorIndex
+         | CtorArity
+         | FieldIndex
+         
+         | Fold DSL DSL
+         | Head
+         | Tail
+         
+         | Instance [String] String DSL{-[InstDecl]-}
+         | Application DSL{-List-}
+           deriving (Data,Typeable,Show)
+
+box x = List [x]
+nil = List []
+append x y = Concat $ List [x,y]
+
+
+fromOut :: Output -> DSL
+fromOut (OApp x y) = App x (List $ map fromOut y)
+fromOut (OList x) = List (map fromOut x)
+fromOut (OString x) = String x
+fromOut x = error $ show ("fromOut",x)
+
+
+{-
+_1 s x1 = App s $ List [x1]
+_2 s x1 x2 = App s $ List [x1,x2]
+_3 s x1 x2 x3 = App s $ List [x1,x2,x3]
+_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]
+
+o x = fromOut $ out x
+
+dslEq :: DSL
+dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull
+    where
+        match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])
+        vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))
+        bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]
+        pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")
+        var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)
+
+        dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]
+-}
+
+
+simplifyDSL :: DSL -> DSL
+simplifyDSL = transform f
+    where
+        f (Concat (List xs)) = case g xs of
+            [x] -> x
+            [] -> List []
+            xs -> Concat $ List xs
+        f x = x
+
+        g (List x:List y:zs) = g $ List (x++y):zs
+        g (List []:xs) = g xs
+        g (String "":xs) = g xs
+        g (x:xs) = x : g xs
+        g [] = []
+
+
+prettyTex :: DSL -> String
+prettyTex = f id . transform g
+    where
+        bracket x = "(" ++ x ++ ")"
+    
+        f b (App x (List [])) = x
+        f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs
+        f b (App x y) = b $ x ++ " " ++ f bracket y
+        f b (Concat x) = b $ "concat " ++ f bracket x
+        f b (Reverse x) = b $ "reverse " ++ f bracket x
+        f b (String x) = show x
+        f b (ShowInt x) = b $ "showInt " ++ f bracket x
+        f b (Int x) = show x
+        f b (List []) = "nil"
+        f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"
+        f b (MapField x) = b $ "mapField " ++ f bracket x
+        f b (MapCtor x) = b $ "mapCtor " ++ f bracket x
+        f b DataName = "dataName"
+        f b CtorName = "ctorName"
+        f b CtorIndex = "ctorIndex"
+        f b CtorArity = "ctorArity"
+        f b FieldIndex = "fieldIndex"
+        f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y
+        f b Head = "head"
+        f b Tail = "tail"
+        f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z
+        f b (Application x) = b $ "application " ++ f bracket x
+
+        g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y
+        g x = x
diff --git a/src/Data/Derive/DSL/Derive.hs b/src/Data/Derive/DSL/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/DSL/Derive.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Data.Derive.DSL.Derive(derive) where
+
+import Data.Derive.DSL.HSE
+import Data.Derive.DSL.DSL
+import Data.Derive.DSL.Apply
+import Data.List
+import Data.Char
+import Data.Maybe
+
+
+data Guess = Guess DSL
+           | GuessFld Int DSL
+           | GuessCtr Int Bool DSL  -- 0 based index, does it mention CtorName
+             deriving Show
+
+
+ctrNames = map ctorName $ dataCtors sample
+
+
+derive :: Out -> [DSL]
+derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]
+
+
+guess :: Output -> [Guess]
+guess (OApp "InstDecl" [OApp "Nothing" [], OList [], OList ctxt,name,typ,bod])
+    | OApp "UnQual" [OApp "Ident" [OString name]] <- name
+    , OList [OApp "TyParen" [OApp "TyApp"
+        [OApp "TyCon" [OApp "UnQual" [OApp "Ident" [OString nam]]]
+        ,OApp "TyVar" [OApp "Ident" [OString var]]]]] <- typ
+    , nam == dataName sample
+    , ctxt <- [x | OApp "ClassA" [OApp "UnQual" [OApp "Ident" [OString x]],_] <- map unparenA ctxt]
+    = [Guess $ Instance ctxt name y | Guess y <- guess bod]
+    where
+        unparenA (OApp "ParenA" [x]) = unparenA x
+        unparenA x = x
+
+guess (OList xs) = guessList xs
+guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)
+    
+guess (OString x) 
+    | Just i <- findIndex (`isSuffixOf` x) ctrNames = [GuessCtr i True $ String (take (length x - length (ctrNames !! i)) x) `append` CtorName]
+    | "Sample" `isSuffixOf` x = [Guess $ String (take (length x - 6) x) `append` DataName]
+    | otherwise =
+         [lift (\d -> append (String $ init x) (ShowInt d)) g | x /= "", isDigit (last x), g <- guess $ OInt $ read [last x]] ++
+         [Guess $ String x]
+
+guess (OInt i) =
+    [GuessFld (fromInteger i) FieldIndex | i `elem` [1,2]] ++
+    [GuessCtr 1 False CtorIndex | i == 1] ++
+    [GuessCtr 1 False CtorArity | i == 2] ++
+    [Guess $ Int i]
+
+guess x = error $ show ("fallthrough",x)
+
+
+{-
+First try and figure out runs to put them in to one possible option
+Then try and figure out similarities to give them the same type
+-}
+guessList :: [Output] -> [Guess]
+guessList xs = mapMaybe sames $ map diffs $ sequence $ map guess xs
+    where
+        -- Given a list of guesses, try and collapse them into one coherent guess
+        -- Each input Guess will guess at a List, so compose with Concat
+        sames :: [Guess] -> Maybe Guess
+        sames xs = do
+            let (is,fs) = unzip $ map fromGuess xs
+            i <- maxim is
+            return $ toGuess i $ Concat $ List fs
+
+        -- Promote each Guess to be a list
+        diffs :: [Guess] -> [Guess]
+
+        diffs (GuessCtr 0 True x0:GuessCtr 1 True x1:GuessCtr 2 True x2:xs)
+            | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (MapCtor x1) : diffs xs
+            where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}
+        
+        diffs (GuessCtr 2 True x2:GuessCtr 1 True x1:GuessCtr 0 True x0:xs)
+            | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (Reverse $ MapCtor x1) : diffs xs
+            where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}
+        
+        diffs (GuessFld 1 x1:GuessFld 2 x2:xs)
+            | f 1 x1 == f 1 x2 = GuessCtr 1 False (MapField x2) : diffs xs
+            where f i x = applyEnv x env{envInput=sample, envField=i}
+        
+        diffs (GuessFld 2 x2:GuessFld 1 x1:xs)
+            | f 1 x1 == f 1 x2 = GuessCtr 1 False (Reverse $ MapField x2) : diffs xs
+            where f i x = applyEnv x env{envInput=sample, envField=i}
+
+        diffs (x:xs) = lift box x : diffs xs
+        diffs [] = []
+
+
+gssFold o@(OApp op [x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)
+    where
+        follow dir (OApp op2 [a,m2,b]) | op == op2 && m == m2 = a2 : follow dir b2
+            where (a2,b2) = if dir then (a,b) else (b,a)
+        follow dir x = [x]
+
+        f dir xs | length xs <= 2 = []
+        f dir xs = map (lift g) $ guess $ OList xs
+            where g = Fold (App op $ List [h,fromOut m,t])
+                  (h,t) = if dir then (Head,Tail) else (Tail,Head)
+
+gssFold _ = []
+
+
+gssApp (OApp "App" [OApp "App" [x,y],z]) = map (lift Application) $ guess $ OList $ fromApp x ++ [y,z]
+    where fromApp (OApp "App" [x,y]) = fromApp x ++ [y]
+          fromApp x = [x]
+gssApp _ = []
+    
+
+lift :: (DSL -> DSL) -> Guess -> Guess
+lift f x = toGuess a (f b)
+    where (a,b) = fromGuess x
+
+
+type GuessState = Maybe (Either Int (Int,Bool))
+
+fromGuess :: Guess -> (GuessState, DSL)
+fromGuess (Guess x) = (Nothing, x)
+fromGuess (GuessFld i x) = (Just (Left i), x)
+fromGuess (GuessCtr i b x) = (Just (Right (i,b)), x)
+
+toGuess :: GuessState -> DSL -> Guess
+toGuess Nothing = Guess
+toGuess (Just (Left i)) = GuessFld i
+toGuess (Just (Right (i,b))) = GuessCtr i b
+
+
+-- return the maximum element, if one exists
+maxim :: [GuessState] -> Maybe GuessState
+maxim [] = Just Nothing
+maxim [x] = Just x
+maxim (Nothing:xs) = maxim xs
+maxim (x:Nothing:xs) = maxim $ x:xs
+maxim (x1:x2:xs) | x1 == x2 = maxim $ x1:xs
+maxim (Just (Right (i1,b1)):Just (Right (i2,b2)):xs) | i1 == i2 = maxim $ Just (Right (i1,max b1 b2)) : xs
+maxim _ = Nothing
diff --git a/src/Data/Derive/DSL/HSE.hs b/src/Data/Derive/DSL/HSE.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/DSL/HSE.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where
+
+import Language.Haskell hiding (List, App, String, Int)
+import Data.Data
+import Data.Generics.Uniplate.DataOnly
+import Data.Maybe
+import Data.List
+import Data.Function
+import Control.Monad.Trans.State
+
+
+---------------------------------------------------------------------
+-- EXAMPLES
+
+{-
+-- data List a = Nil | Cons a (List a)
+list :: Input
+list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]
+-}
+
+
+-- data Sample a = First | Second a a | Third a
+sample :: Input
+sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs []
+    where
+        ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]
+        ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ tyVar "a"
+
+
+---------------------------------------------------------------------
+-- UTILITIES
+
+outEq :: Out -> Out -> Bool
+outEq = (==) `on` transformBi (const sl)
+
+---------------------------------------------------------------------
+
+showOut x = unlines $ map prettyPrint x
+
+
+type Input = DataDecl
+type Ctor = CtorDecl
+
+dataName = dataDeclName
+dataVars = length . dataDeclVars
+dataCtors = dataDeclCtors
+ctorName = ctorDeclName
+ctorArity = fromIntegral . ctorDeclArity
+
+ctorIndex :: Input -> Ctor -> Integer
+ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat
+
+
+toInput :: DataDecl -> Input
+toInput x = x
+
+
+type Out = [Decl]
+
+
+
+data Output = OString String
+            | OInt Integer
+            | OApp String [Output]
+            | OList [Output]
+            | OIgnore
+            | OCustom String
+              deriving (Eq,Show,Data,Typeable)
+
+
+toOutput :: Data a => a -> Output
+toOutput x
+    | t == typeOf "" = OString $ coerce x
+    | c == "[]" = OList $ fList x
+    | t == typeOf sl = OIgnore
+    | t == typeOf (1 :: Integer) = OInt $ coerce x
+    | otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)
+    where
+        t = typeOf x
+        c = show $ fst $ splitTyConApp t
+
+        fList :: Data a => a -> [Output]
+        fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]
+
+fromOutput :: Data a => Output -> a
+fromOutput (OList xs) = res
+    where res = f xs
+          f [] = fromConstr $ readCon dat "[]"
+          f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"
+          dat = dataTypeOf res
+          
+          g :: (Data a, Data b) => Output -> a -> b
+          g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x
+
+fromOutput (OApp str args) = res
+    where dat = dataTypeOf res
+          res = evalState (fromConstrM f $ readCon dat str) args
+          f :: Data a => State [Output] a
+          f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else
+                              do x:xs <- get; put xs; return $ fromOutput x
+
+fromOutput (OString x) = coerce x
+fromOutput (OInt x) = coerce x
+
+
+coerce x = fromMaybe (error "Error in coerce") $ cast x
+readCon dat x = fromMaybe (error $ "Error in readCon, " ++ x) $ readConstr dat x
+out x = toOutput x
+fromState :: State a x -> x
+fromState = undefined
diff --git a/src/Data/Derive/DSL/SYB.hs b/src/Data/Derive/DSL/SYB.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/DSL/SYB.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE RelaxedPolyRec, RankNTypes, ScopedTypeVariables #-}
+{- OPTIONS_GHC -fglasgow-exts -}
+
+module Data.Derive.DSL.SYB(dslSYB) where
+
+import Data.Derive.DSL.HSE
+import qualified Language.Haskell.Exts as H
+import Data.Derive.DSL.DSL
+import Control.Monad.Trans.State
+import Control.Monad
+import Data.Generics
+import Data.Maybe
+
+
+dslSYB :: DSL -> Maybe Out
+dslSYB = syb
+
+
+syb :: Data a => DSL -> Maybe a
+syb = dsimple & dlistAny & dapp -- & derr
+
+lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)
+lift f = maybe Nothing id . cast . f
+
+(&) a b x = a x `mplus` b x
+
+
+dlistAny :: forall a . Data a => DSL -> Maybe a
+dlistAny x | isNothing con = Nothing
+           | otherwise = res 
+    where
+        con = readConstr dat "(:)"
+        val = fromConstr (fromJust con) :: a
+        
+        dat = dataTypeOf (undefined :: a)
+        
+        res = gmapQi 0 f val
+
+        f :: Data d => d -> Maybe a
+        f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]
+
+
+dlist :: Data a => DSL -> Maybe [a]
+dlist x = do
+    List xs <- return x
+    mapM syb xs
+
+
+dapp :: forall a . Data a => DSL -> Maybe a
+dapp x = do
+    App name (List args) <- return x
+    let dat = dataTypeOf (undefined :: a)
+        (res,s) = runState (fromConstrM f $ readCon dat name) (True,args)
+    if fst s then Just res else Nothing
+    where
+        f :: forall b . Data b => State (Bool,[DSL]) b
+        f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl
+            else do
+                (b,x:xs) <- get
+                case syb x of
+                    Nothing -> do put (False,xs) ; return undefined
+                    Just y -> do put (b,xs) ; return y
+
+
+dsimple :: Data a => DSL -> Maybe a
+dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle
+
+
+dinstance :: DSL -> Maybe Decl
+dinstance x = do
+    Instance _ name bod <- return x
+    bod <- syb bod
+    return $ InstDecl sl Nothing []
+        [ClassA (UnQual $ Ident "Data") [TyVar $ Ident "d_type"]]
+        (UnQual $ Ident name) [TyVar $ Ident "d_type"]
+        bod
+
+
+dstring :: DSL -> Maybe String
+dstring x = do
+    String x <- return x
+    return x
+
+
+dmapctor :: DSL -> Maybe Exp
+dmapctor x = do
+    App "List" (List [MapCtor x]) <- return x
+    x <- syb x
+    return $ ListComp x [QualStmt $ Generator sl (PVar $ Ident "d_ctor")
+        (H.App (v "d_dataCtors") (Paren $ ExpTypeSig sl (v "undefined") (TyVar $ Ident "d_type")))]
+
+
+dsingle :: DSL -> Maybe Exp
+dsingle (App "Lit" (List [App "Int" (List [CtorArity])])) = Just $ Paren $ H.App (v "d_ctorArity") (v "d_ctor")
+dsingle (App "Lit" (List [App "Int" (List [CtorIndex])])) = Just $ Paren $ H.App (v "d_ctorIndex") (v "d_ctor")
+dsingle (App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []])) = Just $ Paren $
+    ExpTypeSig sl (H.App (v "d_ctorValue") (v "d_ctor")) (TyVar $ Ident "d_type")
+dsingle _ = Nothing
+
+
+dapplication :: DSL -> Maybe Exp
+dapplication x = do
+    Application (List xs) <- return x
+    syb $ f xs
+    where
+        f (x:y:z) = f (App "App" (List [x,y]) : z)
+        f [x] = x
+
+
+v = Var . UnQual . Ident
diff --git a/src/Data/Derive/Data.hs b/src/Data/Derive/Data.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Data.hs
@@ -0,0 +1,154 @@
+module Data.Derive.Data(makeData) where
+{-
+import Data.Data
+
+example :: Custom
+
+instance (Data a, Typeable a) => Data (Sample a) where
+    gfoldl k r (First) = r First
+    gfoldl k r (Second x1 x2) = r Second `k` x1 `k` x2
+    gfoldl k r (Third x1) = r Third `k` x1
+
+    gunfold k z c = case constrIndex c - 1 of
+        0 -> z First
+        1 -> const k 1 $ const k 2 $ z Second
+        2 -> const k 1 $ z Third
+        i -> error $ ("Data.gunfold for Sample" ++ ", unknown index: ") ++ show i
+
+    toConstr x@First{}  = indexConstr (dataTypeOf x) (0+1)
+    toConstr x@Second{} = indexConstr (dataTypeOf x) (1+1)
+    toConstr x@Third{}  = indexConstr (dataTypeOf x) (2+1)
+
+    dataTypeOf _ = ty
+        where ty = mkDataType $(dataName)
+                   [mkConstr ty "First"  $(ctorFields 0) $(ctorFixity 0)
+                   ,mkConstr ty "Second" $(ctorFields 1) $(ctorFixity 1)
+                   ,mkConstr ty "Third"  $(ctorFields 2) $(ctorFixity 2)]
+
+test :: Computer
+
+instance Data Computer where
+    gfoldl k r (Laptop x1 x2) = r Laptop `k` x1 `k` x2
+    gfoldl k r (Desktop x1) = r Desktop `k` x1
+    gunfold k z c = case constrIndex c - 1 of
+        0 -> k $ k $ z Laptop
+        1 -> k $ z Desktop
+        i -> error $ "Data.gunfold for Computer, unknown index: " ++ show i
+    toConstr x@Laptop{} = indexConstr (dataTypeOf x) 1
+    toConstr x@Desktop{} = indexConstr (dataTypeOf x) 2
+    dataTypeOf _ = ty
+      where ty = mkDataType "Example.Computer"
+                 [mkConstr ty "Laptop" ["weight", "speed"] Prefix
+                 ,mkConstr ty "Desktop" ["speed"] Prefix]
+
+-}
+
+import Data.Derive.DSL.HSE
+import qualified Language.Haskell as H
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeData :: Derivation
+makeData = derivationCustomDSL "Data" custom $
+    List [Instance ["Data","Typeable"] "Data" (List [App "InsDecl" (
+    List [App "FunBind" (List [MapCtor (App "Match" (List [App "Ident"
+    (List [String "gfoldl"]),List [App "PVar" (List [App "Ident" (List
+    [String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])]
+    ),App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
+    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
+    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App
+    "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App
+    "Ident" (List [String "k"])])]),Head])) (Concat (List [Reverse (
+    MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "r"])])]),App "Con" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])])])])]]))]),App "Nothing" (List [])]))])
+    ]),App "InsDecl" (List [App "FunBind" (List [List [App "Match" (
+    List [App "Ident" (List [String "gunfold"]),List [App "PVar" (List
+    [App "Ident" (List [String "k"])]),App "PVar" (List [App "Ident" (
+    List [String "z"])]),App "PVar" (List [App "Ident" (List [String
+    "c"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
+    "Case" (List [App "InfixApp" (List [App "App" (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "constrIndex"]
+    )])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "c"])])])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List
+    [Int 1])])]),Concat (List [MapCtor (App "Alt" (List [App "PLit" (
+    List [App "Signless" (List []),App "Int" (List [CtorIndex])]),App
+    "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
+    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String "$"
+    ])])]),Tail])) (Concat (List [MapField (Application (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "const"
+    ])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "k"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])]
+    )),List [App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "z"])])]),App "Con" (List [App "UnQual" (
+    List [App "Ident" (List [CtorName])])])])]]))]),App "Nothing" (
+    List [])])),List [App "Alt" (List [App "PVar" (List [App "Ident" (
+    List [String "i"])]),App "UnGuardedRhs" (List [App "InfixApp" (
+    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "error"])])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String "$"])])]),App "InfixApp" (List [App "Paren"
+    (List [App "InfixApp" (List [App "Lit" (List [App "String" (List [
+    Concat (List [String "Data.gunfold for ",DataName])])]),App
+    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
+    "++"])])]),App "Lit" (List [App "String" (List [String
+    ", unknown index: "])])])]),App "QVarOp" (List [App "UnQual" (List
+    [App "Symbol" (List [String "++"])])]),App "App" (List [App "Var"
+    (List [App "UnQual" (List [App "Ident" (List [String "show"])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i"
+    ])])])])])])]),App "Nothing" (List [])])]])])]),App "Nothing" (
+    List [])])]])]),App "InsDecl" (List [App "FunBind" (List [MapCtor
+    (App "Match" (List [App "Ident" (List [String "toConstr"]),List [
+    App "PAsPat" (List [App "Ident" (List [String "x"]),App "PRec" (
+    List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []]
+    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Application
+    (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "indexConstr"])])]),App "Paren" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "dataTypeOf"])])]),App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "x"])])])])]),App "Paren" (List [App
+    "InfixApp" (List [App "Lit" (List [App "Int" (List [CtorIndex])]),
+    App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
+    "+"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])])]),App
+    "Nothing" (List [])]))])]),App "InsDecl" (List [App "FunBind" (
+    List [List [App "Match" (List [App "Ident" (List [String
+    "dataTypeOf"]),List [App "PWildCard" (List [])],App "Nothing" (
+    List []),App "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "ty"])])])]),App "Just" (List [App
+    "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [App
+    "Ident" (List [String "ty"])]),App "UnGuardedRhs" (List [
+    Application (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "mkDataType"])])]),App "SpliceExp" (List [
+    App "ParenSplice" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "dataName"])])])])]),App "List" (List [
+    MapCtor (Application (List [App "Var" (List [App "UnQual" (List [
+    App "Ident" (List [String "mkConstr"])])]),App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "ty"])])]),App "Lit" (
+    List [App "String" (List [CtorName])]),App "SpliceExp" (List [App
+    "ParenSplice" (List [App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "ctorFields"])])]),App
+    "Lit" (List [App "Int" (List [CtorIndex])])])])]),App "SpliceExp"
+    (List [App "ParenSplice" (List [App "App" (List [App "Var" (List [
+    App "UnQual" (List [App "Ident" (List [String "ctorFixity"])])]),
+    App "Lit" (List [App "Int" (List [CtorIndex])])])])])]))])])]),App
+    "Nothing" (List [])])]])])])]])])])]
+-- GENERATED STOP
+
+
+custom d = customContext context d . customSplice splice d
+
+splice :: FullDataDecl -> Exp -> Exp
+splice d x | x ~= "dataName" = H.Lit $ H.String $ prettyPrint (fst d) ++ "." ++ dataDeclName (snd d)
+splice d (H.App x (H.Lit (H.Int y)))
+    | x ~= "ctorFields" = H.List $ [H.Lit $ H.String a | (a,_) <- ctorDeclFields ctor, a /= ""]
+    | x ~= "ctorFixity" = Con (UnQual (Ident "Prefix"))
+    where ctor = dataDeclCtors (snd d) !! fromInteger y
+
+context :: FullDataDecl -> Context -> Context
+context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVarsStar $ snd d, t <- ["Typeable","Data"]]
diff --git a/src/Data/Derive/DataAbstract.hs b/src/Data/Derive/DataAbstract.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/DataAbstract.hs
@@ -0,0 +1,59 @@
+{-|
+    For deriving Data on abstract data types.
+-}
+module Data.Derive.DataAbstract(makeDataAbstract) where
+{-
+import Data.Data(Data(..))
+
+example :: Custom
+
+instance Typeable a => Data (Sample a) where
+    gfoldl k r x = r x
+    gunfold = error "Data.gunfold not implemented on abstract data type: Sample"
+    toConstr = error "Data.gunfold not implemented on abstract data type: Sample"
+    dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"
+
+-}
+
+import Data.Derive.DSL.HSE
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeDataAbstract :: Derivation
+makeDataAbstract = derivationCustomDSL "DataAbstract" custom $
+    List [Instance ["Typeable"] "Data" (List [App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "gfoldl"]),List [App "PVar" (List [App "Ident" (List [
+    String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])])
+    ,App "PVar" (List [App "Ident" (List [String "x"])])],App
+    "Nothing" (List []),App "UnGuardedRhs" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "r"])])
+    ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "x"])])])])]),App "Nothing" (List [])])]])]),App "InsDecl" (List [
+    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "gunfold"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var"
+    (List [App "UnQual" (List [App "Ident" (List [String "error"])])])
+    ,App "Lit" (List [App "String" (List [Concat (List [String
+    "Data.gunfold not implemented on abstract data type: ",DataName])]
+    )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App
+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "toConstr"])]),App "UnGuardedRhs" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "error"
+    ])])]),App "Lit" (List [App "String" (List [Concat (List [String
+    "Data.gunfold not implemented on abstract data type: ",DataName])]
+    )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App
+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "dataTypeOf"])]),App "UnGuardedRhs" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "error"
+    ])])]),App "Lit" (List [App "String" (List [Concat (List [String
+    "Data.gunfold not implemented on abstract data type: ",DataName])]
+    )])])]),App "Nothing" (List [])])])])]
+-- GENERATED STOP
+
+custom = customContext context
+
+context :: FullDataDecl -> Context -> Context
+context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
diff --git a/src/Data/Derive/Default.hs b/src/Data/Derive/Default.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Default.hs
@@ -0,0 +1,32 @@
+module Data.Derive.Default where
+{-
+import "derive" Data.Derive.Class.Default
+
+example :: Sample
+
+instance Default a => Default (Sample a) where
+    def = head [First, Second (const def 1) (const def 2), Third (const def 1)]
+
+-}
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeDefault :: Derivation
+makeDefault = derivationDSL "Default" dslDefault
+
+dslDefault =
+    List [Instance ["Default"] "Default" (List [App "InsDecl" (List [
+    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "def"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "head"])])]),
+    App "List" (List [MapCtor (Application (Concat (List [List [App
+    "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])])
+    ],MapField (App "Paren" (List [Application (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [String "const"])])]),App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "def"])
+    ])]),App "Lit" (List [App "Int" (List [FieldIndex])])])]))])))])])
+    ]),App "Nothing" (List [])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Enum.hs b/src/Data/Derive/Enum.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Enum.hs
@@ -0,0 +1,52 @@
+module Data.Derive.Enum where
+{-
+import Prelude
+
+example :: Sample
+
+instance Enum (Sample a) where
+    toEnum 0 = First{}
+    toEnum 1 = Second{}
+    toEnum 2 = Third{}
+    toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "Sample"
+
+    fromEnum (First{}) = 0
+    fromEnum (Second{}) = 1
+    fromEnum (Third{}) = 2
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeEnum :: Derivation
+makeEnum = derivationDSL "Enum" dslEnum
+
+dslEnum =
+    List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind"
+    (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List
+    [String "toEnum"]),List [App "PLit" (List [App "Signless" (List []
+    ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [
+    App "Ident" (List [CtorName])]),List []])]),App "Nothing" (List []
+    )])),List [App "Match" (List [App "Ident" (List [String "toEnum"])
+    ,List [App "PVar" (List [App "Ident" (List [String "n"])])],App
+    "Nothing" (List []),App "UnGuardedRhs" (List [App "InfixApp" (List
+    [App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "error"])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol"
+    (List [String "$"])])]),Fold (App "InfixApp" (List [Head,App
+    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
+    "++"])])]),Tail])) (List [App "Lit" (List [App "String" (List [
+    String "toEnum "])]),App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "n"])])])]),
+    App "Lit" (List [App "String" (List [String ", not defined for "])
+    ]),App "Lit" (List [App "String" (List [DataName])])])])]),App
+    "Nothing" (List [])])]])])]),App "InsDecl" (List [App "FunBind" (
+    List [MapCtor (App "Match" (List [App "Ident" (List [String
+    "fromEnum"]),List [App "PParen" (List [App "PRec" (List [App
+    "UnQual" (List [App "Ident" (List [CtorName])]),List []])])],App
+    "Nothing" (List []),App "UnGuardedRhs" (List [App "Lit" (List [App
+    "Int" (List [CtorIndex])])]),App "Nothing" (List [])]))])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/EnumCyclic.hs b/src/Data/Derive/EnumCyclic.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/EnumCyclic.hs
@@ -0,0 +1,105 @@
+module Data.Derive.EnumCyclic where
+{-
+import Prelude(Enum)
+
+example :: Sample
+
+instance Enum (Sample a) where
+    toEnum 0 = First{}
+    toEnum 1 = Second{}
+    toEnum 2 = Third{}
+    toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample"
+
+    fromEnum (First{}) = 0
+    fromEnum (Second{}) = 1
+    fromEnum (Third{}) = 2
+
+
+    succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)
+        where b = fromEnum a
+
+    pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)
+        where b = fromEnum a
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeEnumCyclic :: Derivation
+makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic
+
+dslEnumCyclic =
+    List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind"
+    (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List
+    [String "toEnum"]),List [App "PLit" (List [App "Signless" (List []
+    ),App "Int" (List [CtorIndex])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "RecConstr" (List [App "UnQual" (List [
+    App "Ident" (List [CtorName])]),List []])]),App "Nothing" (List []
+    )])),List [App "Match" (List [App "Ident" (List [String "toEnum"])
+    ,List [App "PVar" (List [App "Ident" (List [String "n"])])],App
+    "Nothing" (List []),App "UnGuardedRhs" (List [App "InfixApp" (List
+    [App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "error"])])]),App "QVarOp" (List [App "UnQual" (List [App "Symbol"
+    (List [String "$"])])]),Fold (App "InfixApp" (List [Head,App
+    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
+    "++"])])]),Tail])) (List [App "Lit" (List [App "String" (List [
+    String "toEnum "])]),App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "show"])])]),App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "n"])])])]),
+    App "Lit" (List [App "String" (List [Concat (List [String
+    ", not defined for ",DataName])])])])])]),App "Nothing" (List [])]
+    )]])])]),App "InsDecl" (List [App "FunBind" (List [MapCtor (App
+    "Match" (List [App "Ident" (List [String "fromEnum"]),List [App
+    "PParen" (List [App "PRec" (List [App "UnQual" (List [App "Ident"
+    (List [CtorName])]),List []])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "Lit" (List [App "Int" (List [CtorIndex]
+    )])]),App "Nothing" (List [])]))])]),App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "succ"]),List [App "PVar" (List [App "Ident" (List [String
+    "a"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
+    "If" (List [App "InfixApp" (List [App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "b"])])]),App "QVarOp" (List [App
+    "UnQual" (List [App "Symbol" (List [String "=="])])]),App "App" (
+    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "length"])])]),App "List" (List [MapCtor (App "RecConstr" (
+    List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []]
+    ))])])]),App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "toEnum"])])]),App "Lit" (List [App "Int" (
+    List [Int 0])])]),App "App" (List [App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "toEnum"])])]),App "Paren" (List [
+    App "InfixApp" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "b"])])]),App "QVarOp" (List [App "UnQual" (
+    List [App "Symbol" (List [String "+"])])]),App "Lit" (List [App
+    "Int" (List [Int 1])])])])])])]),App "Just" (List [App "BDecls" (
+    List [List [App "PatBind" (List [App "PVar" (List [App "Ident" (
+    List [String "b"])]),App "UnGuardedRhs" (List [App "App" (List [
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "a"])])])])]),App "Nothing" (List [])])]])])])]])]),
+    App "InsDecl" (List [App "FunBind" (List [List [App "Match" (List
+    [App "Ident" (List [String "pred"]),List [App "PVar" (List [App
+    "Ident" (List [String "a"])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "If" (List [App "InfixApp" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "b"])])
+    ]),App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
+    String "=="])])]),App "Lit" (List [App "Int" (List [Int 0])])]),
+    App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "toEnum"])])]),App "Paren" (List [App "App" (List [
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [
+    App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])
+    ])]),App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "toEnum"])])]),App "Paren" (List [App
+    "InfixApp" (List [App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "b"])])]),App "QVarOp" (List [App "UnQual" (List [
+    App "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (
+    List [Int 1])])])])])])]),App "Just" (List [App "BDecls" (List [
+    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
+    String "b"])]),App "UnGuardedRhs" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "fromEnum"])])]),App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "a"])])])])]),App "Nothing" (List [])])]])])])]])])]
+    )]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Eq.hs b/src/Data/Derive/Eq.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Eq.hs
@@ -0,0 +1,60 @@
+module Data.Derive.Eq where
+{-
+import Prelude
+
+example :: Sample
+
+instance (Eq a) => Eq (Sample a) where
+    First == First = True
+    Second x1 x2 == Second y1 y2 = x1 == y1 && x2 == y2 && True
+    Third x1 == Third y1 = x1 == y1 && True
+    _ == _ | length [First{},Second{},Third{}] > 1 = False
+
+test :: Assoced
+instance Eq typ => Eq (Assoced typ) where
+    Assoced x1 x2 == Assoced y1 y2 = x1 == y1 && x2 == y2
+
+test :: TwoParam
+instance Eq b => Eq (TwoParam a b) where
+    TwoParam x1 == TwoParam y1 = x1 == y1
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeEq :: Derivation
+makeEq = derivationDSL "Eq" dslEq
+
+dslEq =
+    List [Instance ["Eq"] "Eq" (List [App "InsDecl" (List [App
+    "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App
+    "Symbol" (List [String "=="]),List [App "PApp" (List [App "UnQual"
+    (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List
+    [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]
+    )]))]),App "PApp" (List [App "UnQual" (List [App "Ident" (List [
+    CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat
+    (List [String "y",ShowInt FieldIndex])])]))])],App "Nothing" (List
+    []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
+    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
+    "&&"])])]),Tail])) (Concat (List [MapField (App "InfixApp" (List [
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
+    List [String "x",ShowInt FieldIndex])])])]),App "QVarOp" (List [
+    App "UnQual" (List [App "Symbol" (List [String "=="])])]),App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
+    String "y",ShowInt FieldIndex])])])])])),List [App "Con" (List [
+    App "UnQual" (List [App "Ident" (List [String "True"])])])]]))]),
+    App "Nothing" (List [])])),List [App "Match" (List [App "Symbol" (
+    List [String "=="]),List [App "PWildCard" (List []),App
+    "PWildCard" (List [])],App "Nothing" (List []),App "GuardedRhss" (
+    List [List [App "GuardedRhs" (List [List [App "Qualifier" (List [
+    App "InfixApp" (List [App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "length"])])]),App
+    "List" (List [MapCtor (App "RecConstr" (List [App "UnQual" (List [
+    App "Ident" (List [CtorName])]),List []]))])]),App "QVarOp" (List
+    [App "UnQual" (List [App "Symbol" (List [String ">"])])]),App
+    "Lit" (List [App "Int" (List [Int 1])])])])],App "Con" (List [App
+    "UnQual" (List [App "Ident" (List [String "False"])])])])]]),App
+    "Nothing" (List [])])]])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Fold.hs b/src/Data/Derive/Fold.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Fold.hs
@@ -0,0 +1,67 @@
+-- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>
+
+{-|
+    A pseudo derivation.  Derive a (non-recursive) fold function for 
+    the type which takes one function per alternative constructor.  Each
+    function takes the same arguments as the constructor and returns
+    a value.  When applied to a value the fold function applies the
+    function for the matching constructor to the constructor fields.
+    This provides a first-class alternative to pattern matching to
+    deconstruct the data type.
+-}
+module Data.Derive.Fold(makeFold) where
+{-
+test :: Computer
+
+foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a
+foldComputer f _ (Laptop x1 x2) = f x1 x2
+foldComputer _ f (Desktop x1) = f x1
+
+test :: Assoced
+
+foldAssoced :: (typ -> String -> a) -> Assoced typ -> a
+foldAssoced f (Assoced x1 x2) = f x1 x2
+
+test :: Either
+
+foldEither :: (a -> c) -> (b -> c) -> Either a b -> c
+foldEither f _ (Left x1) = f x1
+foldEither _ f (Right x1) = f x1
+
+test :: Bool
+
+foldBool :: a -> a -> Bool -> a
+foldBool f _ False = f
+foldBool _ f True = f
+
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+import Data.List
+import Data.Generics.Uniplate.DataOnly
+
+
+makeFold :: Derivation
+makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d
+
+
+mkFold :: DataDecl -> [Decl]
+mkFold d | isIdent $ dataDeclName d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f [0..] $ dataDeclCtors d]
+         | otherwise = []
+    where
+        n = "fold" ++ title (dataDeclName d)
+        f i c = Match sl (name n) pat Nothing (UnGuardedRhs bod) Nothing
+            where pat = replicate i PWildCard ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) PWildCard ++
+                        [PParen $ PApp (qname $ ctorDeclName c) (map pVar vars)]
+                  bod = apps (var "f") (map var vars)
+                  vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]
+
+
+foldType :: DataDecl -> Type
+foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]
+    where
+        dt = dataDeclType d
+        v = head $ map (tyVar . return) ['a'..] \\ universe dt
+        f c = TyParen $ tyFun $ map snd (ctorDeclFields c) ++ [v]
+
diff --git a/src/Data/Derive/Foldable.hs b/src/Data/Derive/Foldable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Foldable.hs
@@ -0,0 +1,55 @@
+{-
+    This module is not written/maintained by the usual Data.Derive author.
+
+    MAINTAINER: Twan van Laarhoven 
+    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
+
+    Please send all patches to this module to Neil (ndmitchell -at- gmail),
+    and CC Twan.
+-}
+
+module Data.Derive.Foldable(makeFoldable, makeFoldableN) where
+
+{-
+import Data.Foldable(Foldable)
+import qualified Data.Foldable(foldr)
+
+test :: FailList
+instance Foldable (FailList t1) where
+    foldr _  b Zoro = b
+    foldr _  b (Fial _) = b
+    foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2)
+
+test :: Sample
+instance Foldable Sample where
+    foldr _  b First = b
+    foldr _f b (Second a1 a2) = _f a1 (_f a2 b)
+    foldr _f b (Third a1) = _f a1 b
+
+test :: Either
+instance Foldable (Either t1) where
+    foldr _  b (Left _) = b
+    foldr _f b (Right a1) = _f a1 b
+-}
+
+import Data.Derive.Internal.Traversal
+import Data.Derive.Internal.Derivation
+import Language.Haskell
+
+
+makeFoldable :: Derivation
+makeFoldable = makeFoldableN 1
+
+makeFoldableN :: Int -> Derivation
+makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable"
+
+foldrTraversal = defaultTraversalType
+        { traversalName   = Qual (ModuleName "Data.Foldable") (Ident "foldr")
+        , traversalFunc   = \n a -> appP (var "flip") $ appP (Var n) a
+        , traversalPlus   = fail "variable used in multiple positions in a data type"
+        , traversalId     = App (var "flip") (var "const")
+        , traverseTuple   =         foldr (.:) $ var "id"
+        , traverseCtor    = const $ foldr (.:) $ var "id"
+        , traverseFunc    = \pat rhs -> Match sl (name "") [pVar "_f", pVar "b", pat] Nothing (UnGuardedRhs $ appP rhs (var "b")) Nothing
+        }
+    where a .: b = InfixApp (paren a) (qvop ".") (paren b)
diff --git a/src/Data/Derive/From.hs b/src/Data/Derive/From.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/From.hs
@@ -0,0 +1,65 @@
+{-|
+    A pseudo derivation.  For each constructor in the data type,
+    deriving @From@ generates @from@/CtorName/ which extracts the
+    components if given the appropriate constructor, and crashes
+    otherwise.  Unlike the DrIFT @\"From\"@ derivation, our version
+    works for all constructors - zero-arity constructors always return
+    @()@, arity-one constructors return the contained value, and all
+    others return a tuple with all the components.
+-}
+
+module Data.Derive.From(makeFrom) where
+
+{-
+
+test :: Sample
+
+fromFirst :: Sample a -> ()
+fromFirst First = ()
+fromFirst _ = error "fromFirst failed, not a First"
+
+fromSecond :: Sample a -> (a, a)
+fromSecond (Second x1 x2) = (x1,x2)
+fromSecond _ = error "fromSecond failed, not a Second"
+
+fromThird :: Sample a -> a
+fromThird (Third x1) = x1
+fromThird _ = error "fromThird failed, not a Third"
+
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+
+
+makeFrom :: Derivation
+makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d
+
+
+makeFromCtor :: DataDecl -> CtorDecl -> [Decl]
+makeFromCtor d c | isIdent n = [TypeSig sl [name from] typ, FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]
+                 | otherwise = []
+    where
+        n = ctorDeclName c
+        from = "from" ++ n
+
+        typ = TyFun (dataDeclType d)
+            (tyTuple $ map snd $ ctorDeclFields c)
+
+        match = Match sl (name from) [pat] Nothing (UnGuardedRhs rhs) Nothing
+        pat = (length vars == 0 ? id $ PParen) $ PApp (qname n) (map pVar vars)
+        vars = take (length $ ctorDeclFields c) $ map ((:) 'x' . show) [1..]
+        rhs = valTuple $ map var vars
+
+        defMatch = Match sl (name from) [PWildCard] Nothing (UnGuardedRhs err) Nothing
+        err = App (var "error") $ Lit $ String $ from ++ " failed, not a " ++ n
+
+
+tyTuple [] = TyCon $ Special UnitCon
+tyTuple [x] = x
+tyTuple xs = TyTuple Boxed xs
+
+
+valTuple [] = Con $ Special UnitCon
+valTuple [x] = x
+valTuple xs = Tuple Boxed xs
diff --git a/src/Data/Derive/Functor.hs b/src/Data/Derive/Functor.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Functor.hs
@@ -0,0 +1,62 @@
+{-
+    This module is not written/maintained by the usual Data.Derive author.
+
+    MAINTAINER: Twan van Laarhoven 
+    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
+
+    Please send all patches to this module to Neil (ndmitchell -at- gmail),
+    and CC Twan.
+-}
+
+-- NOTE: Cannot be guessed as it relies on type information
+
+-- | Derives 'Functor', as discussed on the Haskell-prime mailing list:
+-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
+module Data.Derive.Functor(makeFunctor,makeFunctorN) where
+
+{-
+import Prelude
+
+test :: FailList
+instance Functor (FailList t1) where
+    fmap _  Zoro = Zoro
+    fmap _  (Fial a1) = Fial a1
+    fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2)
+
+test :: State
+instance Functor (State t1) where
+    fmap _f (StateT a1) = StateT (fmap _f . a1)
+
+test :: Sample
+instance Functor Sample where
+    fmap _  First = First
+    fmap _f (Second a1 a2) = Second (_f a1) (_f a2)
+    fmap _f (Third a1) = Third (_f a1)
+-}
+
+
+import Data.Derive.Internal.Traversal
+import Data.Derive.Internal.Derivation
+import Language.Haskell
+
+
+makeFunctor :: Derivation
+makeFunctor = makeFunctorN 1
+
+makeFunctorN :: Int -> Derivation
+makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor"
+
+functorTraversal = defaultTraversalType
+        { traversalName   = qname "fmap"
+        , traverseArrow   = Just functorForArrowType
+        , traverseFunc    = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) Nothing
+        }
+
+functorForArrowType :: Exp -> Exp -> Exp
+functorForArrowType a b
+  | isId a && isId b  =  var "id"
+  | isId a            =  LeftSection b (qvop ".")
+  | isId b            =  RightSection (qvop ".") a
+  | otherwise         =  Lambda sl [pVar "arg"] $ b .: var "arg" .: a
+ where isId = (var "id" ==)
+       a .: b = InfixApp (paren a) (qvop ".") (paren b)
diff --git a/src/Data/Derive/Has.hs b/src/Data/Derive/Has.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Has.hs
@@ -0,0 +1,40 @@
+{-|
+    Has is a pseudo derivation.  For each field of any constructor of
+    the data type, Has generates @has@/FieldName/ which returns 'True'
+    if given the the given field is a member of the constructor of the
+    passed object, and 'False' otherwise.
+-}
+module Data.Derive.Has(makeHas) where
+
+{-
+test :: Computer
+
+hasSpeed :: Computer -> Bool
+hasSpeed _ = True
+
+hasWeight :: Computer -> Bool
+hasWeight Laptop{} = True
+hasWeight _ = False
+
+test :: Sample
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+import Data.List
+
+
+makeHas :: Derivation
+makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d
+
+
+makeHasField :: DataDecl -> String -> [Decl]
+makeHasField d field = if isIdent field then [TypeSig sl [name has] typ, binds has ms] else []
+    where
+        has = "has" ++ title field
+        typ = TyFun (dataDeclType d) (tyCon "Bool")
+        (yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d
+        match pat val = ([pat], con val)
+
+        ms | null no = [match PWildCard "True"]
+           | otherwise = [match (PRec (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match PWildCard "False"]
diff --git a/src/Data/Derive/Instance/Arities.hs b/src/Data/Derive/Instance/Arities.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Instance/Arities.hs
@@ -0,0 +1,14 @@
+-- GENERATED START
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}
+
+module Data.Derive.Instance.Arities where
+
+import Data.Derive.Class.Arities
+import Data.Derive.Internal.Instance
+
+instance Data d_type => Arities d_type where
+        arities _
+          = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |
+             d_ctor <- d_dataCtors (undefined :: d_type)]
+
+-- GENERATED STOP
diff --git a/src/Data/Derive/Internal/Derivation.hs b/src/Data/Derive/Internal/Derivation.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Internal/Derivation.hs
@@ -0,0 +1,49 @@
+
+module Data.Derive.Internal.Derivation(
+    Derivation(..),
+    derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,
+    customSplice, customContext
+    ) where
+
+import Data.DeriveDSL
+import Data.Derive.DSL.HSE
+import Data.Generics.Uniplate.DataOnly
+
+
+data Derivation = Derivation
+    {derivationName :: String
+    ,derivationOp :: Type -> (String -> Decl) -> FullDataDecl -> Either String [Decl]
+    }
+
+
+derivationParams :: String -> ([Type] -> (String -> Decl) -> FullDataDecl -> Either String [Decl]) -> Derivation
+derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs
+
+
+derivationCustom :: String -> (FullDataDecl -> Either String [Decl]) -> Derivation
+derivationCustom name op = derivationParams name $ \ty grab decs -> op decs
+
+
+derivationDSL :: String -> DSL -> Derivation
+derivationDSL name dsl = derivationCustomDSL name (const id) dsl
+
+
+derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation
+derivationCustomDSL name custom dsl = derivationCustom name $
+    \d -> case applyDSL dsl $ snd d of
+              Left x -> Left x
+              Right x -> Right $ simplify $ custom d x
+
+
+customSplice :: (FullDataDecl -> Exp -> Exp) -> (FullDataDecl -> [Decl] -> [Decl])
+customSplice custom d = transformBi f
+    where
+        f (SpliceExp (ParenSplice x)) = custom d x
+        f x = x
+
+
+customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl])
+customContext custom ds = map f
+    where
+        f (InstDecl sl a b ctx c d e) = InstDecl sl a b (custom ds ctx) c d e
+        f x = x
diff --git a/src/Data/Derive/Internal/Instance.hs b/src/Data/Derive/Internal/Instance.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Internal/Instance.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Data.Derive.Internal.Instance(
+    Data, d_ctorArity, d_ctorValue, d_dataCtors
+    ) where
+
+import Data.Data
+import Control.Monad
+import Control.Monad.Trans.State
+
+
+data Ctor = Ctor
+    {ctorType :: Box
+    ,ctorRep :: Constr}
+
+
+data Box = forall a . Data a => Box a
+
+
+d_ctorArity :: Ctor -> Int
+d_ctorArity Ctor{ctorType=Box t, ctorRep=rep} = flip execState 0 $
+    liftM (`asTypeOf` t) $
+    fromConstrM (modify (+1) >> return undefined) rep
+
+
+d_ctorValue :: Data a => Ctor -> a
+d_ctorValue = error "TODO: d_ctorValue"
+
+
+d_dataCtors :: Data a => a -> [Ctor]
+d_dataCtors x
+    | not $ isAlgType t = error "d_dataCtors only works on algebraic data types"
+    | otherwise = map (Ctor $ Box x) $ dataTypeConstrs t
+    where t = dataTypeOf x
diff --git a/src/Data/Derive/Internal/Traversal.hs b/src/Data/Derive/Internal/Traversal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Internal/Traversal.hs
@@ -0,0 +1,211 @@
+{-# LANGUAGE CPP #-}
+{-
+    This module is not written/maintained by the usual Data.Derive author.
+
+    MAINTAINER: Twan van Laarhoven 
+    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
+
+    Please send all patches to this module to Neil (ndmitchell -at- gmail),
+    and CC Twan.
+-}
+
+-- NOTE: Cannot be guessed as it relies on type information
+
+-- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:
+-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
+module Data.Derive.Internal.Traversal(
+        TraveralType(..), defaultTraversalType,
+        traversalDerivation1,
+        traversalInstance, traversalInstance1,
+        deriveTraversal
+    ) where
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+import Data.List
+import qualified Data.Set as S
+import Control.Monad.Trans.Writer
+import Control.Applicative
+import Data.Generics.Uniplate.DataOnly
+import Data.Maybe
+import Prelude
+
+---------------------------------------------------------------------------------
+-- Information datatype, public interface
+
+-- | An expression representing a traversal of a subpart of the data
+type Trav = Exp
+
+-- | What kind of traversal are we deriving?
+data TraveralType = TraveralType
+        { traversalArg    :: Int                     -- ^ On what position are we traversing?
+        , traversalCo     :: Bool                    -- ^ covariant?
+        , traversalName   :: QName                   -- ^ name of the traversal function
+        , traversalId     :: Trav                    -- ^ Identity traversal
+        , traversalDirect :: Trav                    -- ^ Traversal of 'a'
+        , traversalFunc   :: QName -> Trav -> Trav  -- ^ Apply the sub-traversal function
+        , traversalPlus   :: Trav -> Trav -> Trav    -- ^ Apply two non-identity traversals in sequence
+        , traverseArrow   :: Maybe (Trav -> Trav -> Trav)    -- ^ Traverse a function type
+        , traverseTuple   :: [Exp] -> Exp            -- ^ Construct a tuple from applied traversals
+        , traverseCtor    :: String -> [Exp] -> Exp  -- ^ Construct a data type from applied traversals
+        , traverseFunc    :: Pat -> Exp -> Match     -- ^ Construct a clause of the traversal function
+        }
+
+defaultTraversalType = TraveralType
+        { traversalArg    = 1
+        , traversalCo     = False
+        , traversalName   = undefined -- prevent warnings
+        , traversalId     = var "id"
+        , traversalDirect = var "_f"
+        , traversalFunc   = \x y -> appP (Var x) y
+        , traversalPlus   = \x y -> apps (Con $ Special Cons) [paren x, paren y]
+        , traverseArrow   = Nothing
+        , traverseTuple   = Tuple Boxed
+        , traverseCtor    = \x y -> apps (con x) (map paren y)
+        , traverseFunc    = undefined
+        }
+
+data RequiredInstance = RequiredInstance
+        { _requiredDataArg  :: String -- ^ What argument of the current data type?
+        , _requiredPosition :: Int    -- ^ What argument position of that type?
+        }
+      deriving (Eq, Ord)
+
+-- | Monad that collects required instances
+type WithInstances a = Writer (S.Set RequiredInstance) a
+
+
+vars f c n = [f $ c : show i | i <- [1..n]]
+
+
+---------------------------------------------------------------------------------
+-- Deriving traversals
+
+
+-- | Derivation for a Traversable like class with just 1 method
+traversalDerivation1 :: TraveralType -> String -> Derivation
+traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm) 
+    where className n = nm ++ (if n > 1 then show n else "")
+
+
+-- | Instance for a Traversable like class with just 1 method
+traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl]
+traversalInstance1 tt nm (_,dat)
+    | isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"
+    | dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"
+    | otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]
+
+
+-- | Instance for a Traversable like class
+traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances Decl] -> [Decl]
+traversalInstance tt nameBase dat bodyM = [simplify $ InstDecl sl Nothing [] ctx nam args (map InsDecl body)]
+    where
+        (body, required) = runWriter (sequence bodyM)
+        ctx  = [ ClassA (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))
+               | RequiredInstance n p <- S.toList required
+               ]
+        vrs  = vars tyVar 't' (dataDeclArity dat)
+        (vrsBefore,_:vrsAfter) = splitAt (length vrs - traversalArg tt) vrs
+        className n = nameBase ++ (if n > 1 then show n else "")
+        nam = qname (className (traversalArg tt))
+        args = TyParen (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter
+
+
+-- | Derive a 'traverse' like function
+deriveTraversal :: TraveralType -> DataDecl -> WithInstances Decl
+deriveTraversal tt dat = fun
+    where
+        fun  = (\xs -> FunBind [Match sl nam a b c d | Match _ _ a b c d <- xs]) <$> body
+        args = argPositions dat
+        nam = unqual $ traversalNameN tt $ traversalArg tt
+        body = mapM (deriveTraversalCtor tt args) (dataDeclCtors dat)
+
+        unqual (Qual _ x) = x
+        unqual (UnQual x) = x
+
+
+-- | Derive a clause of a 'traverse' like function for a constructor
+deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDecl -> WithInstances Match
+deriveTraversalCtor tt ap ctor = do
+    let nam = ctorDeclName ctor
+        arity = ctorDeclArity ctor
+    tTypes <- mapM (deriveTraversalType tt ap) (map snd $ ctorDeclFields ctor)
+    return $ traverseFunc tt (PParen $ PApp (qname nam) (vars pVar 'a' arity))
+           $ traverseCtor tt nam (zipWith App tTypes (vars var 'a' arity))
+
+
+
+-- | Derive a traversal for a type
+deriveTraversalType :: TraveralType -> ArgPositions -> Type -> WithInstances Trav
+deriveTraversalType tt ap (TyParen x) = deriveTraversalType tt ap x
+deriveTraversalType tt ap TyForall{}  = fail "forall not supported in traversal deriving"
+deriveTraversalType tt ap (TyFun a b)
+                                           = fromJust (traverseArrow tt)
+                                                 <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a
+                                                 <*> deriveTraversalType tt                                     ap b
+deriveTraversalType tt ap (TyApp a b)      = deriveTraversalApp tt ap a [b] -- T a b c ...
+deriveTraversalType tt ap (TyList a)       = deriveTraversalType tt ap $ TyApp (TyCon $ Special ListCon) a
+deriveTraversalType tt ap (TyTuple b a)    = deriveTraversalType tt ap $ tyApps (TyCon $ Special $ TupleCon b $ length a) a
+deriveTraversalType tt ap (TyCon n)        = return $ traversalId tt -- T
+deriveTraversalType tt ap (TyVar (Ident n)) -- a
+  | ap n /= traversalArg tt                = return $ traversalId tt
+  | traversalCo tt                         = fail "tyvar used in covariant position"
+  | otherwise                              = return $ traversalDirect tt
+
+
+-- | Find all arguments to a type application, then derive a traversal
+deriveTraversalApp :: TraveralType -> ArgPositions -> Type -> [Type] -> WithInstances Trav
+deriveTraversalApp tt ap (TyApp a b) args = deriveTraversalApp tt ap a (b : args)
+deriveTraversalApp tt ap tycon@TyTuple{} args = do -- (a,b,c)
+         tArgs <- mapM (deriveTraversalType tt ap) args
+         return $
+           if (all (== traversalId tt) tArgs) then
+             traversalId tt
+           else
+             Lambda sl [PTuple Boxed (vars pVar 't' (length args))]
+                  (traverseTuple tt $ zipWith App tArgs (vars var 't' (length args)))
+deriveTraversalApp tt ap tycon args = do -- T a b c
+         tCon  <- deriveTraversalType tt ap tycon
+         tArgs <- mapM (deriveTraversalType tt ap) args
+         -- need instances?
+         case tycon of
+           TyVar (Ident n) | ap n == traversalArg tt -> fail "kind error: type used type constructor"
+                   | otherwise               -> tell $ S.fromList
+                                                [ RequiredInstance n i
+                                                | (t,i) <- zip (reverse tArgs) [1..]
+                                                , t /= traversalId tt
+                                                ]
+           _ -> return ()
+         -- combine non-id traversals
+         let nonId = [ traverseArg tt i t
+                     | (t,i) <- zip (reverse tArgs) [1..]
+                     , t /= traversalId tt
+                     ]
+         return $ case nonId of
+           [] -> traversalId tt -- no interesting arguments to type con
+           _  -> foldl1 (traversalPlus tt) nonId
+
+
+-- | Lift a traversal to the argument of a type constructor
+traverseArg :: TraveralType -> Int -> Trav -> Trav
+traverseArg tt n e   =  traversalFunc tt (traversalNameN tt n) e
+
+traversalNameN :: TraveralType -> Int -> QName
+traversalNameN tt n | n <= 1    = nm
+                    | otherwise = nm `f` (if n > 1 then show n else "")
+  where nm = traversalName tt
+        f (Qual m x) y = Qual m $ x `g` y
+        f (UnQual x) y = UnQual $ x `g` y
+        g (Ident x) y = Ident $ x ++ y
+
+-- | Information on argument positions
+type ArgPositions = String -> Int
+
+-- | Position of an argument in the data type
+--   In the type  "data X a b c"
+--   positions are: a -> 3, b -> 2, c -> 1
+argPositions :: DataDecl -> String -> Int
+argPositions dat = \nm -> case elemIndex nm args of
+    Nothing -> error "impossible: tyvar not in scope"
+    Just k  -> length args - k
+ where args = dataDeclVars dat
diff --git a/src/Data/Derive/Is.hs b/src/Data/Derive/Is.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Is.hs
@@ -0,0 +1,33 @@
+module Data.Derive.Is(makeIs) where
+{-
+
+test :: Sample
+
+isFirst :: Sample a -> Bool
+isFirst (First{}) = True ; isFirst _ = False
+
+isSecond :: Sample a -> Bool
+isSecond (Second{}) = True ; isSecond _ = False
+
+isThird :: Sample a -> Bool
+isThird (Third{}) = True ; isThird _ = False
+
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+
+
+makeIs :: Derivation
+makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d
+
+
+makeIsCtor :: DataDecl -> CtorDecl -> [Decl]
+makeIsCtor d c = if not $ isIdent $ ctorDeclName c then [] else
+        [TypeSig sl [name nam] (dataDeclType d `TyFun` tyCon "Bool")
+        ,FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]
+    where
+        nam = "is" ++ ctorDeclName c
+        
+        match = Match sl (name nam) [PParen $ PRec (qname $ ctorDeclName c) []] Nothing (UnGuardedRhs $ con "True") Nothing
+        defMatch = Match sl (name nam) [PWildCard] Nothing (UnGuardedRhs $ con "False") Nothing
diff --git a/src/Data/Derive/JSON.hs b/src/Data/Derive/JSON.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/JSON.hs
@@ -0,0 +1,165 @@
+-- |
+-- Copyright:   (c) Bertram Felgenhauer 2009
+-- License:     BSD3
+-- Stability:   experimental
+-- Portability: portable
+--
+-- Derive 'Text.JSON' instances.
+--
+-- Unlike Text.JSON.Generics, single constructor types are /not/ handled
+-- specially. Every value is encoded as an object with a single field,
+-- with the constructor name as key and the values as its contents.
+--
+-- If the constructor is a record, the contents is an Object with the
+-- field names as keys. Otherwise, the contents is an array.
+
+module Data.Derive.JSON (makeJSON) where
+
+import qualified Language.Haskell as H
+import Language.Haskell (
+    Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt,
+    (~=), var, pVar, con, strE, strP, apps, qname, sl,
+    ctorDeclFields, ctorDeclName, dataDeclCtors)
+
+{-
+import "json" Text.JSON
+import Text.JSON.Types
+
+example :: Custom
+instance JSON a => JSON (Sample a) where
+    readJSON (JSObject x)   = $(readJSON)
+    readJSON _              = Error "..."
+    showJSON (First)        = $(showJSON 0)
+    showJSON (Second x1 x2) = $(showJSON 1)
+    showJSON (Third x1)     = $(showJSON 2)
+-}
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeJSON :: Derivation
+makeJSON = derivationCustomDSL "JSON" custom $
+    List [Instance ["JSON"] "JSON" (List [App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "readJSON"]),List [App "PParen" (List [App "PApp" (List [
+    App "UnQual" (List [App "Ident" (List [String "JSObject"])]),List
+    [App "PVar" (List [App "Ident" (List [String "x"])])]])])],App
+    "Nothing" (List []),App "UnGuardedRhs" (List [App "SpliceExp" (
+    List [App "ParenSplice" (List [App "Var" (List [App "UnQual" (List
+    [App "Ident" (List [String "readJSON"])])])])])]),App "Nothing" (
+    List [])]),App "Match" (List [App "Ident" (List [String "readJSON"
+    ]),List [App "PWildCard" (List [])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "App" (List [App "Con" (List [App
+    "UnQual" (List [App "Ident" (List [String "Error"])])]),App "Lit"
+    (List [App "String" (List [String "..."])])])]),App "Nothing" (
+    List [])])]])]),App "InsDecl" (List [App "FunBind" (List [MapCtor
+    (App "Match" (List [App "Ident" (List [String "showJSON"]),List [
+    App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
+    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
+    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
+    "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "showJSON"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])
+    ])])]),App "Nothing" (List [])]))])])])]
+-- GENERATED STOP
+
+-- ^ 'Derivation' for 'JSON'
+
+custom :: FullDataDecl -> [Decl] -> [Decl]
+custom = customSplice splice
+
+splice :: FullDataDecl -> Exp -> Exp
+splice d x | x ~= "readJSON" = mkRead d
+splice d (H.App x (H.Lit (H.Int y))) | x~= "showJSON" = mkShow d y
+splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e
+
+------------------------------------------------------------------------------
+-- showJSON
+
+mkShow :: FullDataDecl -> Integer -> Exp
+mkShow d y = let
+    hasFields = any (not . null . fst) (ctorDeclFields c)
+    c = dataDeclCtors (snd d) !! fromInteger y
+    mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields
+  in
+    mkJSObject $ H.List
+        [H.Tuple H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]
+
+mkShowPlainFields :: FieldDecl -> Exp
+mkShowPlainFields fs = mkJSArray $ H.List
+    [var "showJSON" `H.App` xi | xi <- vars "x" fs]
+
+mkShowRecordFields :: FieldDecl -> Exp
+mkShowRecordFields fs = mkJSObject $ H.List
+    [ H.Tuple H.Boxed [strE fn, var "showJSON" `H.App` xi]
+    | ((fn, _), xi) <- zip fs (vars "x" fs)]
+
+------------------------------------------------------------------------------
+-- readJSON
+
+mkRead :: FullDataDecl -> Exp
+mkRead (_, d) = let
+    readError = con "Error" `H.App` strE "malformed JSON for type ...: ..."
+  in
+    H.Case (var "fromJSObject" `H.App` var "x") $
+    map mkReadCtor (dataDeclCtors d) ++
+    [H.Alt H.sl H.PWildCard (H.UnGuardedRhs readError) Nothing]
+
+mkReadCtor :: CtorDecl -> Alt
+mkReadCtor c = let
+    cn = ctorDeclName c
+    fs = ctorDeclFields c
+    hasFields = any (not . null . fst) fs
+    body | hasFields = mkReadRecord cn fs
+         | otherwise = mkReadPlain cn fs
+  in
+    H.Alt sl (H.PList [H.PTuple H.Boxed [strP cn, pVar "y"]])
+         (H.UnGuardedRhs body) Nothing
+
+mkReadRecord :: String -> FieldDecl -> Exp
+mkReadRecord cn fs = H.Do $
+    [H.Generator sl (H.PApp (qname "JSObject") [pVar "z"])
+          (var "return" `H.App` var "y")] ++
+    [H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d")
+          (H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z")
+          Nothing]] ++
+    zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++
+    mkReadTrailer cn fs
+
+mkReadRecordField :: String -> Pat -> (String, Type) -> Stmt
+mkReadRecordField cn xi (fn, _) = H.Generator sl xi $
+    apps (var "maybe") [
+        var "fail" `H.App` strE (unwords ["readJSON: missing field", fn,
+                                          "while decoding a", cn]),
+        var "return",
+        apps (var "lookup") [strE fn, var "d"]]
+
+mkReadPlain :: String -> FieldDecl -> Exp
+mkReadPlain cn fs = H.Do $
+    [H.Generator sl (H.PApp (qname "JSArray") [H.PList (pVars "x" fs)])
+        (var "return" `H.App` var "y")] ++
+    mkReadTrailer cn fs
+
+mkReadTrailer :: String -> FieldDecl -> [Stmt]
+mkReadTrailer cn fs =
+    [ H.Generator sl yi (var "readJSON" `H.App` xi)
+    | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++
+    [H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)]
+
+------------------------------------------------------------------------------
+-- utilites
+
+mkJSObject :: Exp -> Exp
+mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e)
+
+mkJSArray :: Exp -> Exp
+mkJSArray e = con "JSArray" `H.App` e
+
+vars :: String -> FieldDecl -> [Exp]
+vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]
+
+pVars :: String -> FieldDecl -> [Pat]
+pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
diff --git a/src/Data/Derive/LazySet.hs b/src/Data/Derive/LazySet.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/LazySet.hs
@@ -0,0 +1,38 @@
+{-|
+    A pseudo derivation.  For each field in the data type, deriving
+    @LazySet@ generates a function like a record updator, but lazy where possible.
+    This is very useful in certain situations to improve laziness
+    properties.  A setter is only lazy if that field is present in one constructor.
+-}
+module Data.Derive.LazySet(makeLazySet) where
+{-
+
+test :: Computer
+
+setSpeed :: Int -> Computer -> Computer
+setSpeed v x = x{speed=v}
+
+setWeight :: Double -> Computer -> Computer
+setWeight v x = Laptop v (speed x)
+
+test :: Sample
+
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+
+
+makeLazySet :: Derivation
+makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d
+
+
+makeLazySetField :: DataDecl -> String -> [Decl]
+makeLazySetField d field = if isIdent field then [TypeSig sl [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else []
+    where
+        fun = "set" ++ title field
+        typ = t `TyFun` (dataDeclType d `TyFun` dataDeclType d)
+        (t,c):tc = [(t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field]
+
+        bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren $ App (var n) (var "x") | (n,t) <- ctorDeclFields c]
+            | otherwise = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]
diff --git a/src/Data/Derive/Lens.hs b/src/Data/Derive/Lens.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Lens.hs
@@ -0,0 +1,41 @@
+{-|
+    A pseudo derivation.  For each field in the data type, deriving
+    @Lens@ generates @lens@/FieldName/@ = lens @/fieldName/@
+    (\ x v -> v { @/fieldName/@ = x })@.
+
+    This works with the @data-lens@ package.
+-}
+module Data.Derive.Lens(makeLens) where
+
+{-
+import "data-lens" Data.Lens.Common
+
+test :: Sample
+
+test :: Computer
+
+lensSpeed :: Lens Computer Int
+lensSpeed = lens speed (\x v -> v{speed = x})
+
+lensWeight :: Lens Computer Double
+lensWeight = lens weight (\x v -> v{weight = x})
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+
+
+makeLens :: Derivation
+makeLens = derivationCustom "Lens" $ \(_,d) -> Right $ concatMap (makeLensField d) $ dataDeclFields d
+
+
+makeLensField :: DataDecl -> String -> [Decl]
+makeLensField d field = if isIdent field then [TypeSig sl [name ref] typ, bind ref [] bod] else []
+    where
+        ref = "lens" ++ title field
+        typ = tyApps (tyCon "Lens") [dataDeclType d, t]
+        Just t = lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
+
+        bod = apps (var "lens")
+            [var field
+            ,Paren $ Lambda sl [pVar "x",pVar "v"] $ RecUpdate (var "v") [FieldUpdate (qname field) (var "x")]]
diff --git a/src/Data/Derive/Monoid.hs b/src/Data/Derive/Monoid.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Monoid.hs
@@ -0,0 +1,69 @@
+{-|
+    Derives an instance of @Monoid@. It uses the product
+    construction of monoids. @mappend@ on two different constructors
+    is undefined.
+-}
+module Data.Derive.Monoid(makeMonoid) where
+{-
+import Data.Monoid hiding (First)
+
+example :: Sample
+instance Monoid a => Monoid (Sample a) where
+    mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]
+    mappend (First) (First) = First
+    mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)
+    mappend (Third x1) (Third y1) = Third (mappend x1 y1)
+    mappend _ _ | length [First{},Second{},Third{}] > 1 = error "Monoid.mappend: Different constructors for Sample"
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeMonoid :: Derivation
+makeMonoid = derivationDSL "Monoid" dslMonoid
+
+dslMonoid =
+    List [Instance ["Monoid"] "Monoid" (List [App "InsDecl" (List [App
+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "mempty"])]),App "UnGuardedRhs" (List [App "App" (List [App "Var"
+    (List [App "UnQual" (List [App "Ident" (List [String "head"])])]),
+    App "List" (List [MapCtor (Application (Concat (List [List [App
+    "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])])
+    ],MapField (App "Paren" (List [Application (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [String "const"])])]),App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "mempty"])])]),App "Lit" (List [App "Int" (List [FieldIndex])])])]
+    ))])))])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App
+    "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App
+    "Ident" (List [String "mappend"]),List [App "PParen" (List [App
+    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
+    MapField (App "PVar" (List [App "Ident" (List [Concat (List [
+    String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App
+    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
+    MapField (App "PVar" (List [App "Ident" (List [Concat (List [
+    String "y",ShowInt FieldIndex])])]))])])],App "Nothing" (List []),
+    App "UnGuardedRhs" (List [Application (Concat (List [List [App
+    "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName])])])
+    ],MapField (App "Paren" (List [Application (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [String "mappend"])])]),App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
+    String "x",ShowInt FieldIndex])])])]),App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [Concat (List [String "y",
+    ShowInt FieldIndex])])])])])]))]))]),App "Nothing" (List [])])),
+    List [App "Match" (List [App "Ident" (List [String "mappend"]),
+    List [App "PWildCard" (List []),App "PWildCard" (List [])],App
+    "Nothing" (List []),App "GuardedRhss" (List [List [App
+    "GuardedRhs" (List [List [App "Qualifier" (List [App "InfixApp" (
+    List [App "App" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "length"])])]),App "List" (List [MapCtor (
+    App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [
+    CtorName])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List
+    [App "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (
+    List [Int 1])])])])],App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"
+    (List [App "String" (List [Concat (List [String
+    "Monoid.mappend: Different constructors for ",DataName])])])])])]]
+    ),App "Nothing" (List [])])]])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/NFData.hs b/src/Data/Derive/NFData.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/NFData.hs
@@ -0,0 +1,35 @@
+module Data.Derive.NFData where
+{-
+import "deepseq" Control.DeepSeq(NFData, rnf)
+
+example :: Sample
+instance NFData a => NFData (Sample a) where
+    rnf (First) = ()
+    rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()
+    rnf (Third x1) = rnf x1 `seq` ()
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeNFData :: Derivation
+makeNFData = derivationDSL "NFData" dslNFData
+
+dslNFData =
+    List [Instance ["NFData"] "NFData" (List [App "InsDecl" (List [App
+    "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [
+    String "rnf"]),List [App "PParen" (List [App "PApp" (List [App
+    "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])]))])])],App "Nothing" (List []),App "UnGuardedRhs"
+    (List [Fold (App "InfixApp" (List [Head,App "QVarOp" (List [App
+    "UnQual" (List [App "Ident" (List [String "seq"])])]),Tail])) (
+    Concat (List [MapField (App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "rnf"])])]),App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [Concat (List [String
+    "x",ShowInt FieldIndex])])])])])),List [App "Con" (List [App
+    "Special" (List [App "UnitCon" (List [])])])]]))]),App "Nothing" (
+    List [])]))])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Ord.hs b/src/Data/Derive/Ord.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Ord.hs
@@ -0,0 +1,95 @@
+module Data.Derive.Ord where
+{-
+import Prelude
+
+example :: Sample
+instance Ord a => Ord (Sample a) where
+    compare a b = check a b
+        where
+            check (First) (First) = EQ
+            check (Second x1 x2) (Second y1 y2) = compare x1 y1 `_then` compare x2 y2 `_then` EQ
+            check (Third x1) (Third y1) = compare x1 y1 `_then` EQ
+            check x y | length [First{},Second{},Third{}] > 1 = compare (tag x) (tag y)
+
+            -- leading _ to avoid a warning when not used
+            EQ `_then` x = x
+            x `_then` _ = x
+
+            tag (First{}) = 0 :: Int
+            tag (Second{}) = 1 :: Int
+            tag (Third{}) = 2 :: Int
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeOrd :: Derivation
+makeOrd = derivationDSL "Ord" dslOrd
+
+dslOrd =
+    List [Instance ["Ord"] "Ord" (List [App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "compare"]),List [App "PVar" (List [App "Ident" (List [
+    String "a"])]),App "PVar" (List [App "Ident" (List [String "b"])])
+    ],App "Nothing" (List []),App "UnGuardedRhs" (List [Application (
+    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "check"])])]),App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "a"])])]),App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "b"])])])])]),App "Just" (List [
+    App "BDecls" (List [List [App "FunBind" (List [Concat (List [
+    MapCtor (App "Match" (List [App "Ident" (List [String "check"]),
+    List [App "PParen" (List [App "PApp" (List [App "UnQual" (List [
+    App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
+    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
+    )]),App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
+    "Ident" (List [Concat (List [String "y",ShowInt FieldIndex])])]))]
+    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App
+    "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App
+    "Ident" (List [String "_then"])])]),Head])) (Concat (List [List [
+    App "Con" (List [App "UnQual" (List [App "Ident" (List [String
+    "EQ"])])])],Reverse (MapField (Application (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [String "compare"])])]),App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
+    String "x",ShowInt FieldIndex])])])]),App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [Concat (List [String "y",
+    ShowInt FieldIndex])])])])])))]))]),App "Nothing" (List [])])),
+    List [App "Match" (List [App "Ident" (List [String "check"]),List
+    [App "PVar" (List [App "Ident" (List [String "x"])]),App "PVar" (
+    List [App "Ident" (List [String "y"])])],App "Nothing" (List []),
+    App "GuardedRhss" (List [List [App "GuardedRhs" (List [List [App
+    "Qualifier" (List [App "InfixApp" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [
+    App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])
+    ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
+    String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])],
+    Application (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "compare"])])]),App "Paren" (List [App "App"
+    (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "tag"])])]),App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "x"])])])])]),App "Paren" (List [App "App" (
+    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    String "tag"])])]),App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "y"])])])])])])])]]),App "Nothing" (List [])
+    ])]])]),App "FunBind" (List [List [App "Match" (List [App "Ident"
+    (List [String "_then"]),List [App "PApp" (List [App "UnQual" (List
+    [App "Ident" (List [String "EQ"])]),List []]),App "PVar" (List [
+    App "Ident" (List [String "x"])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "x"])])])]),App "Nothing" (List [])]),App
+    "Match" (List [App "Ident" (List [String "_then"]),List [App
+    "PVar" (List [App "Ident" (List [String "x"])]),App "PWildCard" (
+    List [])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "x"])])
+    ])]),App "Nothing" (List [])])]]),App "FunBind" (List [MapCtor (
+    App "Match" (List [App "Ident" (List [String "tag"]),List [App
+    "PParen" (List [App "PRec" (List [App "UnQual" (List [App "Ident"
+    (List [CtorName])]),List []])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [App "ExpTypeSig" (List [App "Lit" (List [App
+    "Int" (List [CtorIndex])]),App "TyCon" (List [App "UnQual" (List [
+    App "Ident" (List [String "Int"])])])])]),App "Nothing" (List [])]
+    ))])]])])])]])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Read.hs b/src/Data/Derive/Read.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Read.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE PatternGuards #-}
+{-|
+    Derives @Read@.  This is as defined by the Haskell report, except
+    there is no support for infix constructors.  If you attempt to
+    derive @Read@ for a data type with infix constructors, the
+    constructors are handled as if they were prefix constructors, using
+    the @(@/consym/@)@ syntax.
+-}
+module Data.Derive.Read(makeRead) where
+
+{-
+import Prelude
+
+example :: Custom
+instance Read a => Read (Sample a) where
+    readsPrec p0 r = 
+        readParen $(bracket 0) (\r0 -> $(comp 0 First )) r ++
+        readParen $(bracket 1) (\r0 -> $(comp 1 Second)) r ++
+        readParen $(bracket 2) (\r0 -> $(comp 2 Third )) r ++
+        []
+
+test :: Sample
+instance Read a => Read (Sample a) where
+    readsPrec p0 r =
+        readParen False (\r0 ->
+            [ (First, r1)
+            | ("First", r1) <- lex r0]) r
+        ++
+        readParen (p0 > 10) (\r0 ->
+            [ (Second x1 x2, r3)
+            | ("Second", r1) <- lex r0
+            , (x1, r2) <- readsPrec 11 r1
+            , (x2, r3) <- readsPrec 11 r2]) r
+        ++
+        readParen (p0 > 10) (\r0 ->
+            [ (Third x1, r2)
+            | ("Third", r1) <- lex r0
+            , (x1, r2) <- readsPrec 11 r1]) r
+
+test :: Computer
+instance Read Computer where
+    readsPrec _ r =
+        readParen False (\r0 ->
+            [ (Laptop x1 x2, r10)
+            | ("Laptop", r1) <- lex r0
+            , ("{", r2) <- lex r1
+            , ("weight", r3) <- lex r2
+            , ("=", r4) <- lex r3
+            , (x1, r5) <- readsPrec 0 r4
+            , (",", r6) <- lex r5
+            , ("speed", r7) <- lex r6
+            , ("=", r8) <- lex r7
+            , (x2, r9) <- readsPrec 0 r8
+            , ("}", r10) <- lex r9]) r
+        ++
+        readParen False (\r0 ->
+            [ (Desktop x1, r6)
+            | ("Desktop", r1) <- lex r0
+            , ("{", r2) <- lex r1
+            , ("speed", r3) <- lex r2
+            , ("=", r4) <- lex r3
+            , (x1, r5) <- readsPrec 0 r4
+            , ("}", r6) <- lex r5]) r
+
+test :: (:*:)
+instance (Read a, Read b) => Read ((:*:) a b) where
+    readsPrec p0 r =
+        readParen (p0 > 10) (\r0 ->
+            [ ((:*:) x1 x2, r3)
+            | ("(:*:)", r1) <- lex r0
+            , (x1, r2) <- readsPrec 11 r1
+            , (x2, r3) <- readsPrec 11 r2]) r
+
+-}
+import Data.Derive.DSL.HSE
+import qualified Language.Haskell as H
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeRead :: Derivation
+makeRead = derivationCustomDSL "Read" custom $
+    List [Instance ["Read"] "Read" (List [App "InsDecl" (List [App
+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [
+    String "readsPrec"]),List [App "PVar" (List [App "Ident" (List [
+    Concat (List [String "p",ShowInt (Int 0)])])]),App "PVar" (List [
+    App "Ident" (List [String "r"])])],App "Nothing" (List []),App
+    "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App
+    "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String
+    "++"])])]),Tail])) (Concat (List [MapCtor (Application (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "readParen"])])]),App "SpliceExp" (List [App "ParenSplice" (List [
+    App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "bracket"])])]),App "Lit" (List [App "Int" (List [
+    CtorIndex])])])])]),App "Paren" (List [App "Lambda" (List [List [
+    App "PVar" (List [App "Ident" (List [Concat (List [String "r",
+    ShowInt (Int 0)])])])],App "SpliceExp" (List [App "ParenSplice" (
+    List [Application (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [String "comp"])])]),App "Lit" (List [App "Int" (
+    List [CtorIndex])]),App "Con" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])])])])])])])]),App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "r"])])])])),List [App
+    "List" (List [List []])]]))]),App "Nothing" (List [])])]])])])]
+-- GENERATED STOP
+
+custom = customSplice splice
+
+getCtor d i = dataDeclCtors (snd d) !! fromIntegral i
+hasFields c = any ((/=) "" . fst) $ ctorDeclFields c
+
+splice :: FullDataDecl -> Exp -> Exp
+splice d (H.App x (H.Lit (H.Int y))) | x ~= "bracket", let c = getCtor d y =
+    if hasFields c || null (ctorDeclFields c)
+    then con "False"
+    else Paren $ InfixApp (var "p0") (QVarOp $ UnQual $ Symbol ">") (H.Lit $ H.Int 10)
+
+splice d (H.App (H.App x (H.Lit (H.Int y))) _) | x ~= "comp" =
+    if hasFields c then readFields c else readCtor c
+    where c = getCtor d y
+
+
+readCtor :: CtorDecl -> Exp
+readCtor c =
+    ListComp (Tuple Boxed [cpat, var ('r':show (cn+1))]) $
+        matchStr (ctorDeclName c) 0 :
+        [QualStmt $ Generator sl
+            (PTuple Boxed [pVar $ v 'x' 0, pVar $ v 'r' 1])
+            (apps (var "readsPrec") [H.Lit $ H.Int 11, var $ v 'r' 0])
+            | i <- [1..cn], let v c j = c : show (i+j)]
+    where
+        cn = ctorDeclArity c
+        cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn]
+
+
+readFields :: CtorDecl -> Exp
+readFields c =
+    ListComp (Tuple Boxed [cpat, var $ 'r':show ((cn*4)+2)]) $
+        matchStr (ctorDeclName c) 0 :
+        concat [
+            matchStr (r == 1 ? "{" $ ",") r :
+            matchStr fld (r+1) :
+            matchStr "=" (r+2) :
+            QualStmt (Generator sl
+                (PTuple Boxed [pVar $ 'x':show i, pVar $ 'r':show (r+4)])
+                (apps (var "readsPrec") [H.Lit $ H.Int 0, var $ 'r':show (r+3)]))
+            : []
+            | (i,r,(fld,_)) <- zip3 [1..] [1,5..] (ctorDeclFields c)
+            ] ++
+        [matchStr "}" ((cn*4)+1)]
+    where
+        cn = ctorDeclArity c
+        cpat = apps (Con $ UnQual $ ctorDeclName' c) $ map (var . ('x':) . show) [1..cn]
+
+
+matchStr :: String -> Int -> QualStmt
+matchStr s i = QualStmt $ Generator sl (PTuple Boxed [PLit H.Signless $ H.String s, pVar $ 'r':show (i+1)]) (var "lex" `H.App` var ('r':show i))
+
+
+
+
+{-
+
+read' dat = [instance_default "Read" dat [funN "readsPrec" [sclause [vr "p0", vr "r"] body]]]
+    where
+        body = (++::) [ readit ctr | ctr <- dataCtors dat ]
+
+readit ctr = case ctorFields ctr of [] -> norm
+                                    fl -> flds fl
+    where
+        norm = lK "readParen"
+               [vr "p0" >: lit (10::Integer),
+                "r0" ->: runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'),
+                l0 "r"]
+
+        flds f = lK "readParen" 
+                 [false,
+                  "r0" ->: runComp (pName . pLex "{" .
+                                    foldr (.) id (intersperse (pLex ",")
+                                                  (zipWith pField (ctv ctr 'x') f)) .
+                                    pLex "}") (ctp ctr 'x'),
+                  l0 "r"]
+
+        runComp fn ex = CompE $ fn (\k -> [ NoBindS (tup [ex, vrn 'r' k]) ]) 0
+
+        pArse pat fun ct k = BindS (tup [pat, vrn 'r' (k+1)]) (AppE fun (vrn 'r' k)) : ct (k+1)
+
+        pLex pat = pArse (lit pat) (l0 "lex")
+
+        name = ctorName ctr
+
+        pName | isAlpha (head name) || head name == '_' = pLex name
+              | otherwise                               = pLex "(" . pLex name . pLex ")"
+
+        pRead pc pat = pArse pat (l1 "readsPrec" (lit (pc :: Integer)))
+
+        pField pat fld = pLex fld . pLex "=" . pRead 0 pat
+-}
diff --git a/src/Data/Derive/Ref.hs b/src/Data/Derive/Ref.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Ref.hs
@@ -0,0 +1,42 @@
+{-|
+    A pseudo derivation.  For each field in the data type, deriving
+    @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =
+    \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.
+
+    This is intended for use with the compositional functional references
+    described in
+    <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.
+-}
+module Data.Derive.Ref(makeRef) where
+
+{-
+test :: Sample
+
+test :: Computer
+
+refSpeed :: Ref Computer
+refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}
+
+refWeight :: Ref Computer
+refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+
+
+makeRef :: Derivation
+makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d
+
+
+makeRefField :: DataDecl -> String -> [Decl]
+makeRefField d field = if isIdent field then [TypeSig sl [name ref] typ, bind ref [] bod] else []
+    where
+        ref = "ref" ++ title field
+        typ = TyApp (tyCon "Ref") (dataDeclType d)
+
+        bod = RecConstr (qname "Ref")
+            [FieldUpdate (qname "select") (var field)
+            ,FieldUpdate (qname "update") $ Lambda sl [pVar "f",pVar "v"] $
+                RecUpdate (var "v") [FieldUpdate (qname field) $ App (var "f") $ Paren $ App (var field) (var "v")]
+            ]
diff --git a/src/Data/Derive/Serial.hs b/src/Data/Derive/Serial.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Serial.hs
@@ -0,0 +1,65 @@
+module Data.Derive.Serial where
+{-
+import "smallcheck" Test.SmallCheck
+
+example :: Sample
+
+instance Serial a => Serial (Sample a) where
+    series = cons0 First \/
+             cons2 Second \/
+             cons1 Third
+
+    coseries rs d = [ \t -> case t of
+                                First -> t0
+                                Second x1 x2 -> t1 x1 x2
+                                Third x1 -> t2 x1
+                    | t0 <- alts0 rs d `const` First{}
+                    , t1 <- alts2 rs d `const` Second{}
+                    , t2 <- alts1 rs d `const` Third{}
+                    ]
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeSerial :: Derivation
+makeSerial = derivationDSL "Serial" dslSerial
+
+dslSerial =
+    List [Instance ["Serial"] "Serial" (List [App "InsDecl" (List [App
+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "series"])]),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List
+    [Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [
+    String "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [
+    String "cons",ShowInt CtorArity])])])]),App "Con" (List [App
+    "UnQual" (List [App "Ident" (List [CtorName])])])]))))]),App
+    "Nothing" (List [])])]),App "InsDecl" (List [App "FunBind" (List [
+    List [App "Match" (List [App "Ident" (List [String "coseries"]),
+    List [App "PVar" (List [App "Ident" (List [String "rs"])]),App
+    "PVar" (List [App "Ident" (List [String "d"])])],App "Nothing" (
+    List []),App "UnGuardedRhs" (List [App "ListComp" (List [App
+    "Lambda" (List [List [App "PVar" (List [App "Ident" (List [String
+    "t"])])],App "Case" (List [App "Var" (List [App "UnQual" (List [
+    App "Ident" (List [String "t"])])]),MapCtor (App "Alt" (List [App
+    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),
+    MapField (App "PVar" (List [App "Ident" (List [Concat (List [
+    String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [
+    Application (Concat (List [List [App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [Concat (List [String "t",ShowInt
+    CtorIndex])])])])],MapField (App "Var" (List [App "UnQual" (List [
+    App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])
+    ])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt"
+    (List [App "Generator" (List [App "PVar" (List [App "Ident" (List
+    [Concat (List [String "t",ShowInt CtorIndex])])]),App "InfixApp" (
+    List [Application (List [App "Var" (List [App "UnQual" (List [App
+    "Ident" (List [Concat (List [String "alts",ShowInt CtorArity])])])
+    ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "rs"])])]),App "Var" (List [App "UnQual" (List [App "Ident" (List
+    [String "d"])])])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Ident" (List [String "const"])])]),App "RecConstr" (List [App
+    "UnQual" (List [App "Ident" (List [CtorName])]),List []])])])]))])
+    ]),App "Nothing" (List [])])]])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Serialize.hs b/src/Data/Derive/Serialize.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Serialize.hs
@@ -0,0 +1,134 @@
+module Data.Derive.Serialize where
+{-
+import "cereal" Data.Serialize
+
+example :: Sample
+
+instance Serialize alpha => Serialize (Sample alpha) where
+    put x = case x of
+        First          -> do putTag 0
+        Second  x1 x2  -> do putTag 1 ; put x1 ; put x2
+        Third   x1     -> do putTag 2 ; put x1
+        where
+            useTag = length [First{}, Second{}, Third{}] > 1
+            putTag x = when useTag (putWord8 x)
+
+    get = do
+        i <- getTag
+        case i of
+            0 -> do return (First)
+            1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)
+            2 -> do x1 <- get ; return (Third x1)
+            _ -> error "Corrupted binary data for Sample"
+        where
+            useTag = length [First{}, Second{}, Third{}] > 1
+            getTag = if useTag then getWord8 else return 0
+
+
+test :: List
+
+instance Serialize a => Serialize (List a) where
+    put x = case x of
+        Nil -> putWord8 0
+        Cons x1 x2 -> do putWord8 1; put x1; put x2
+
+    get = do
+        i <- getWord8
+        case i of
+            0 -> return Nil
+            1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)
+            _ -> error "Corrupted binary data for List"
+
+test :: Assoced
+
+instance Serialize typ => Serialize (Assoced typ) where
+    put (Assoced x1 x2) = do put x1; put x2
+    get = do x1 <- get; x2 <- get; return (Assoced x1 x2)
+
+
+-}
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeSerialize :: Derivation
+makeSerialize = derivationDSL "Serialize" dslSerialize
+
+dslSerialize =
+    List [Instance ["Serialize"] "Serialize" (List [App "InsDecl" (
+    List [App "FunBind" (List [List [App "Match" (List [App "Ident" (
+    List [String "put"]),List [App "PVar" (List [App "Ident" (List [
+    String "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [
+    App "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List
+    [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App
+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])]))]),App "UnGuardedRhs" (List [App "Do" (List [
+    Concat (List [List [App "Qualifier" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "putTag"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])
+    ],MapField (App "Qualifier" (List [App "App" (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "put"])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (
+    List [String "x",ShowInt FieldIndex])])])])])]))])])]),App
+    "Nothing" (List [])]))])]),App "Just" (List [App "BDecls" (List [
+    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [
+    String "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List
+    [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "length"])])]),App "List" (List [MapCtor (App
+    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
+    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
+    [Int 1])])])]),App "Nothing" (List [])]),App "FunBind" (List [List
+    [App "Match" (List [App "Ident" (List [String "putTag"]),List [App
+    "PVar" (List [App "Ident" (List [String "x"])])],App "Nothing" (
+    List []),App "UnGuardedRhs" (List [Application (List [App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "when"])])]),
+    App "Var" (List [App "UnQual" (List [App "Ident" (List [String
+    "useTag"])])]),App "Paren" (List [App "App" (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [Concat (List [String
+    "putWord",ShowInt (Int 8)])])])]),App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [String "x"])])])])])])]),App "Nothing" (
+    List [])])]])]])])])]])]),App "InsDecl" (List [App "PatBind" (List
+    [App "PVar" (List [App "Ident" (List [String "get"])]),App
+    "UnGuardedRhs" (List [App "Do" (List [List [App "Generator" (List
+    [App "PVar" (List [App "Ident" (List [String "i"])]),App "Var" (
+    List [App "UnQual" (List [App "Ident" (List [String "getTag"])])])
+    ]),App "Qualifier" (List [App "Case" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "i"])])]),Concat (List [
+    MapCtor (App "Alt" (List [App "PLit" (List [App "Signless" (List [
+    ]),App "Int" (List [CtorIndex])]),App "UnGuardedRhs" (List [App
+    "Do" (List [Concat (List [MapField (App "Generator" (List [App
+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])]),App "Var" (List [App "UnQual" (List [App "Ident"
+    (List [String "get"])])])])),List [App "Qualifier" (List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "return"])])]),App "Paren" (List [Application (Concat
+    (List [List [App "Con" (List [App "UnQual" (List [App "Ident" (
+    List [CtorName])])])],MapField (App "Var" (List [App "UnQual" (
+    List [App "Ident" (List [Concat (List [String "x",ShowInt
+    FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [])])),
+    List [App "Alt" (List [App "PWildCard" (List []),App
+    "UnGuardedRhs" (List [App "App" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "error"])])]),App "Lit"
+    (List [App "String" (List [Concat (List [String
+    "Corrupted binary data for ",DataName])])])])]),App "Nothing" (
+    List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [List
+    [App "PatBind" (List [App "PVar" (List [App "Ident" (List [String
+    "useTag"])]),App "UnGuardedRhs" (List [App "InfixApp" (List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "length"])])]),App "List" (List [MapCtor (App
+    "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName
+    ])]),List []]))])]),App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String ">"])])]),App "Lit" (List [App "Int" (List
+    [Int 1])])])]),App "Nothing" (List [])]),App "PatBind" (List [App
+    "PVar" (List [App "Ident" (List [String "getTag"])]),App
+    "UnGuardedRhs" (List [App "If" (List [App "Var" (List [App
+    "UnQual" (List [App "Ident" (List [String "useTag"])])]),App "Var"
+    (List [App "UnQual" (List [App "Ident" (List [Concat (List [String
+    "getWord",ShowInt (Int 8)])])])]),App "App" (List [App "Var" (List
+    [App "UnQual" (List [App "Ident" (List [String "return"])])]),App
+    "Lit" (List [App "Int" (List [Int 0])])])])]),App "Nothing" (List
+    [])])]])])])])])]
+-- GENERATED STOP
diff --git a/src/Data/Derive/Set.hs b/src/Data/Derive/Set.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Set.hs
@@ -0,0 +1,40 @@
+{-|
+    A pseudo derivation.  For each field in the data type, deriving
+    @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.
+    This derivation is intended to work around the fact that in Haskell
+    assigning to a field is not a first class object (although
+    extracting from a field is).
+-}
+module Data.Derive.Set(makeSet) where
+
+{-
+
+test :: Computer
+
+setSpeed :: Int -> Computer -> Computer
+setSpeed v x = x{speed=v}
+
+setWeight :: Double -> Computer -> Computer
+setWeight v x = x{weight=v}
+
+test :: Sample
+
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+import Data.Maybe
+
+
+makeSet :: Derivation
+makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d
+
+
+makeSetField :: DataDecl -> String -> [Decl]
+makeSetField d field = [TypeSig sl [name set] typ, bind set [pVar "v",pVar "x"] bod]
+    where
+        set = "set" ++ title field
+        typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d)
+        typField = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
+
+        bod = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]
diff --git a/src/Data/Derive/Show.hs b/src/Data/Derive/Show.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Show.hs
@@ -0,0 +1,90 @@
+
+-- | Derives @Show@.  This is as defined by the Haskell report, except
+-- there is no support for infix constructors.  If you attempt to
+-- derive @Show@ for a data type with infix constructors, the
+-- constructors are handled as if they were prefix constructors, using
+-- the @(@/consym/@)@ syntax.
+module Data.Derive.Show(makeShow) where
+
+{-
+import Prelude
+
+example :: Custom
+instance Show a => Show (Sample a) where
+    showsPrec p (First) = $(show 0)
+    showsPrec p (Second x1 x2) = $(show 1)
+    showsPrec p (Third x1) = $(show 2)
+
+
+test :: Sample
+instance Show a => Show (Sample a) where
+    showsPrec _ First = showString "First"
+    showsPrec p (Second x1 x2) = showParen (p > 10) $ showString "Second " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
+    showsPrec p (Third x1) = showParen (p > 10) $ showString "Third " . showsPrec 11 x1
+
+test :: Computer
+instance Show Computer where
+    showsPrec _ (Laptop x1 x2) =
+        showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'
+    showsPrec _ (Desktop x1) =
+        showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}'
+
+test :: (:*:)
+instance (Show a, Show b) => Show ((:*:) a b) where
+    showsPrec p ((:*:) x1 x2) = showParen (p > 10) $ showString "(:*:) " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2
+-}
+
+import Data.List
+import Data.Derive.DSL.HSE
+import qualified Language.Haskell as H
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeShow :: Derivation
+makeShow = derivationCustomDSL "Show" custom $
+    List [Instance ["Show"] "Show" (List [App "InsDecl" (List [App
+    "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [
+    String "showsPrec"]),List [App "PVar" (List [App "Ident" (List [
+    String "p"])]),App "PParen" (List [App "PApp" (List [App "UnQual"
+    (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List
+    [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]
+    )]))])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App
+    "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App
+    "Var" (List [App "UnQual" (List [App "Ident" (List [String "show"]
+    )])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])])]),App
+    "Nothing" (List [])]))])])])]
+-- GENERATED STOP
+
+-- Left is a literal string, Right is a variable
+
+custom = customSplice splice
+
+splice :: FullDataDecl -> Exp -> Exp
+splice d (H.App x (H.Lit (H.Int y))) | x ~= "show" = combine $ compress $
+        if fields then customFields c else customPlain c
+    where
+        fields = any (not . null . fst) (ctorDeclFields c)
+        c = dataDeclCtors (snd d) !! fromInteger y
+
+        out (Left [x]) = H.App (var "showChar") (H.Lit $ H.Char x)
+        out (Left xs ) = H.App (var "showString") (H.Lit $ H.String xs)
+        out (Right x) = apps (var "showsPrec") [H.Lit $ H.Int (fields ? 0 $ 11), var $ 'x' : show x]
+
+        compress (Left x:Left y:z) = compress $ Left (x++y) : z
+        compress (x:y) = x : compress y
+        compress [] = []
+
+        paren = InfixApp (H.App (var "showParen") (Paren $ InfixApp (var "p") (qvop ">") (H.Lit $ H.Int 10))) (qvop "$")
+        combine xs = (fields || or [' ' `notElem` x | Left x <- xs] ? id $ paren) $
+                     foldr1 (\x y -> InfixApp x (qvop ".") y) $ map out xs
+
+
+customPlain :: CtorDecl -> [Either String Int]
+customPlain c = intersperse (Left " ") $ Left (ctorDeclName c) : map Right [1..length (ctorDeclFields c)]
+
+customFields :: CtorDecl -> [Either String Int]
+customFields c = Left (ctorDeclName c ++ " {") : concat (intersperse [Left ", "] xs) ++ [Left "}"]
+    where xs = [[Left (n ++ " = "), Right i] | (i,(n,t)) <- zip [1..] $ ctorDeclFields c]
diff --git a/src/Data/Derive/Traversable.hs b/src/Data/Derive/Traversable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Traversable.hs
@@ -0,0 +1,56 @@
+{-
+    This module is not written/maintained by the usual Data.Derive author.
+
+    MAINTAINER: Twan van Laarhoven 
+    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"
+
+    Please send all patches to this module to Neil (ndmitchell -at- gmail),
+    and CC Twan.
+-}
+
+-- NOTE: Cannot be guessed as it relies on type information
+
+module Data.Derive.Traversable(makeTraversable, makeTraversableN) where
+
+{-
+import Data.Traversable
+import Control.Applicative(pure, (<*>))
+
+instance Traversable (FailList t1) where
+    traverse _f (Zoro) = pure Nil
+    traverse _f (Fial a1) = pure (Fial a1)
+    traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2
+
+instance Traversable Sample where
+    traverse _f (First) = pure First
+    traverse _f (Second a1 a2) = (Second <$> _f a1) <*> _f a2
+    traverse _f (Third a1) = Third <$> _f a1
+
+instance Traversable (Either t1) where
+    traverse _f (Left a1) = pure (Left a1)
+    traverse _f (Right a1) = Right <$> _f a1
+-}
+
+import Data.Derive.Internal.Traversal
+import Data.Derive.Internal.Derivation
+import Language.Haskell
+
+
+makeTraversable :: Derivation
+makeTraversable = makeTraversableN 1
+
+makeTraversableN :: Int -> Derivation
+makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable"
+
+traverseTraversal = defaultTraversalType
+        { traversalName  = qname "traverse"
+        , traversalId    = var "pure"
+        , traversalPlus  = fail "variable used in multiple positions in a data type"
+        , traverseTuple  = \args -> liftAN (Con $ Special $ TupleCon Unboxed $ length args) args
+        , traverseCtor   = \ctor -> liftAN (con ctor)
+        , traverseFunc   = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) Nothing
+        }
+
+liftAN :: Exp -> [Exp] -> Exp
+liftAN base args = foldl (<*>) (appP (var "pure") base) args
+    where x <*> y = InfixApp (paren x) (QVarOp $ UnQual $ Symbol "<*>") (paren y)
diff --git a/src/Data/Derive/Typeable.hs b/src/Data/Derive/Typeable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Typeable.hs
@@ -0,0 +1,96 @@
+{-|
+    Derivation for the 'Typeable' class, as described in the Scrap
+    Your Boilerplate papers.  This derivation generates instances for
+    all kinds of TypeableK classes; as such we do NOT require the
+    GHC-specific generic downkinding instances to provide lower kind
+    instances.
+
+    Also creates a @typename_\<the type name\>@ value to hold the
+    'TypeRep'.
+-}
+module Data.Derive.Typeable(makeTypeable) where
+{-
+import Data.Typeable
+
+test :: Bool
+typename_Bool :: TyCon
+typename_Bool = mkTyCon3 "package" "Example" "Bool"
+instance Typeable Bool where
+    typeOf _ = mkTyConApp typename_Bool []
+
+test :: Sample
+typename_Sample :: TyCon
+typename_Sample = mkTyCon3 "package" "Example" "Sample"
+instance Typeable1 Sample where
+    typeOf1 _ = mkTyConApp typename_Sample []
+instance Typeable a => Typeable (Sample a) where
+    typeOf = typeOfDefault
+
+test :: Either
+typename_Either :: TyCon
+typename_Either = mkTyCon3 "package" "Example" "Either"
+instance Typeable2 Either where
+    typeOf2 _ = mkTyConApp typename_Either []
+instance Typeable a => Typeable1 (Either a) where
+    typeOf1 = typeOf1Default
+instance (Typeable a, Typeable b) => Typeable (Either a b) where
+    typeOf = typeOfDefault
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+import Data.List
+
+-- based on the macros in: http://darcs.haskell.org/packages/base/include/Typeable.h
+
+{-
+#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable1 (tycon a) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
+  typeOf = typeOfDefault }
+
+#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \
+instance Typeable a => Typeable2 (tycon a) where { \
+  typeOf2 = typeOf2Default }; \
+instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \
+  typeOf1 = typeOf1Default }; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \
+  typeOf = typeOfDefault }
+-}
+
+
+makeTypeable :: Derivation
+makeTypeable = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x
+
+
+mkTypeable :: String -> DataDecl -> [Decl]
+mkTypeable modu d =
+    [TypeSig sl [name fun] (tyCon "TyCon")] ++
+    [PatBind sl (pVar fun) (UnGuardedRhs bod) Nothing |
+        let bod = apps (var "mkTyCon3") [Lit $ String "package", Lit $ String modu, Lit $ String nam]] ++
+    [inst [] (showN n) [tyCon nam] [PWildCard] $ apps (var "mkTyConApp") [var fun, List []]] ++
+    [inst [ClassA (qname "Typeable") [v] | v <- tvs] i [TyParen $ tyApp (tyCon nam) tvs] [] $ var $ "typeOf" ++ i ++ "Default"
+        | (vs,i) <- zip (tail $ inits $ dataDeclVars d) $ map showN [n-1,n-2..]
+        , let tvs = map tyVar vs]
+    where
+        nam = dataDeclName d
+        fun = "typename_" ++ nam
+        n = length $ dataDeclVars d
+
+
+inst ctxt n typ pat expr =
+    InstDecl sl Nothing [] ctxt (qname $ "Typeable" ++ n) typ
+        [InsDecl $ bind ("typeOf" ++ n) pat expr]
+
+showN 0 = ""
+showN n = show n
diff --git a/src/Data/Derive/UniplateDirect.hs b/src/Data/Derive/UniplateDirect.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/UniplateDirect.hs
@@ -0,0 +1,220 @@
+{-# LANGUAGE PatternGuards #-}
+-- NOTE: Cannot be guessed as it relies on type information
+
+-- | Derive Uniplate and Biplate using the Direct combinators.
+--   You must request monomorphic instances, i.e:
+--
+-- > data Foo a = Foo a (Bool, a)
+-- >
+-- > {-!
+-- > deriving instance UniplateDirect (Foo Int)
+-- > deriving instance UniplateDirect (Bool, Int) Int
+-- > deriving instance UniplateDirect (Foo Int) Int
+-- > !-}
+--
+--   This will generate the instances @Uniplate (Foo Int)@,
+--   @Biplate (Bool, Int) Int@ and @Biplate (Foo Int) Int@.
+--   Generally, start with the instance you are after (e.g. @UniplateDirect (Foo Int)@),
+--   try to compile and add further instances as necessary. @UniplateDirect@ with
+--   one argument derives Uniplate, and with two arguments derives Biplate.
+--
+--   @deriving UniplateDirect@ on a data type with no arguments derives Uniplate
+--   with all type parameters defaulting to @()@.
+module Data.Derive.UniplateDirect(makeUniplateDirect) where
+
+
+{-
+import "uniplate" Data.Generics.Uniplate.Direct
+
+
+-- test tuples
+test :: UniplateDirect ((), Maybe ()) ()
+instance Biplate ((), Maybe ()) () where
+    {-# INLINE biplate #-}
+    biplate (x1, x2) = plate (,) |* x1 |+ x2
+
+test :: UniplateDirect (Sample Int)
+instance Uniplate (Sample Int) where
+    {-# INLINE uniplate #-}
+    uniplate x = plate x
+
+test :: UniplateDirect (Sample Int) Int
+instance Biplate (Sample Int) Int where
+    {-# INLINE biplate #-}
+    biplate (Second x1 x2) = plate Second |* x1 |* x2
+    biplate (Third x1) = plate Third |* x1
+    biplate x = plate x
+
+test :: UniplateDirect Computer
+instance Uniplate Computer where
+    {-# INLINE uniplate #-}
+    uniplate x = plate x
+
+test :: UniplateDirect Computer Computer
+instance Biplate Computer Computer where
+    {-# INLINE biplate #-}
+    biplate = plateSelf
+
+test :: UniplateDirect Computer Double
+instance Biplate Computer Double where
+    {-# INLINE biplate #-}
+    biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2
+    biplate x = plate x
+
+test :: UniplateDirect (Assoced (Maybe Bool)) Char
+instance Biplate (Assoced (Maybe Bool)) Char where
+    {-# INLINE biplate #-}
+    biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2
+
+-- test following external declarations
+test :: UniplateDirect (Either Bool Computer) Int
+instance Biplate (Either Bool Computer) Int where
+    {-# INLINE biplate #-}
+    biplate (Right x1) = plate Right |+ x1
+    biplate x = plate x
+
+-- test recursive bits
+test :: UniplateDirect (List Int) Bool
+instance Biplate (List Int) Bool where
+    {-# INLINE biplate #-}
+    biplate x = plate x
+-}
+
+import Language.Haskell
+import Data.Generics.Uniplate.DataOnly
+import Data.Derive.Internal.Derivation
+import Data.Maybe
+import qualified Data.Map as Map
+import Control.Arrow
+import Control.Monad.Trans.State
+
+
+makeUniplateDirect :: Derivation
+makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $
+    let known = map (declName &&& id) knownCtors
+        grab2 x = fromMaybe (grab x) $ lookup x known
+    in case args of
+        _ | not $ null [() | TyVar _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"
+        [] -> make True grab2 x x
+            where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon $ Special UnitCon
+        [x] -> make True grab2 x x
+        [x,y] -> make False grab2 x y
+        _ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)
+        
+
+make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl]
+make uni grab from to = Right [InstDecl sl Nothing [] [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni])
+        [InsDecl $ InlineSig sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]]
+    where
+        ty = grab $ tyRoot from
+        match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) Nothing
+        ms = if uni || from /= to
+             then FunBind $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (var "plate" `App` var "x") | any isNothing bods]
+             else PatBind sl (pVar "biplate") (UnGuardedRhs $ var "plateSelf") Nothing
+        bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty
+
+
+make1 :: (String -> DataDecl) -> (String,[Type]) -> S (Maybe (Pat, Exp))
+make1 grab (name,tys) = do
+    ops <- mapM (fmap show . operator grab) tys
+    let vars = ['x':show i | i <- [1..length tys]]
+        pat = PParen $ PApp (qname name) $ map pVar vars
+        (good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars
+        bod = foldl (\x (y,z) -> InfixApp x (QVarOp $ UnQual $ Symbol y) z) (App (var "plate") $ paren $ apps (con name) (map snd good)) bad
+    return $ if all (== "|-") ops then Nothing else Just (pat,bod)
+
+
+data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq
+
+instance Show Ans where
+    show Hit = "|*"
+    show Miss = "|-"
+    show Try = "|+"
+    show ListHit = "||*"
+    show ListTry = "||+"
+
+ansList Hit = ListHit
+ansList Miss = Miss
+ansList _ = ListTry
+
+
+ansJoin (Miss:xs) = ansJoin xs
+ansJoin [] = Miss
+ansJoin _ = Try
+
+
+type S a = State (Map.Map Type Ans) a
+
+run :: Type -> S a -> a
+run to act = evalState act (Map.singleton to Hit)
+
+operator :: (String -> DataDecl) -> Type -> S Ans
+operator grab from = do
+    mp <- get
+    case Map.lookup from mp of
+        Just y -> return y
+        Nothing -> do
+            fix Miss
+    where
+        fix ans = do
+            s <- get
+            modify $ Map.insert from ans
+            ans2 <- operator2 grab from
+            if ans == ans2
+                then return ans
+                else put s >> fix ans2
+
+
+operator2 :: (String -> DataDecl) -> Type -> S Ans
+operator2 grab from
+    | isTyFun from = return Try
+    | Just from2 <- fromTyList from = fmap ansList $ operator grab from2
+    | otherwise = case subst from $ grab $ tyRoot from of
+        Left from2 -> operator grab from2
+        Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs
+
+
+subst :: Type -> Decl -> Either Type [(String,[Type])]
+subst ty x@TypeDecl{} = Left $ substType ty x
+subst ty x = Right $ substData ty x
+
+substData :: Type -> Decl -> [(String,[Type])]
+substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]
+    where
+        rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)
+        f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
+        f x = x
+
+substType :: Type -> Decl -> Type
+substType ty (TypeDecl _ _ vars d) = fromTyParens $ transform f d
+    where
+        rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)
+        f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep
+        f x = x
+
+
+knownCtors :: [Decl]
+knownCtors = map (fromParseResult . parseDecl)
+    ["data Int = Int"
+    ,"data Bool = Bool"
+    ,"data Char = Char"
+    ,"data Double = Double"
+    ,"data Float = Float"
+    ,"data Integer = Integer"
+    ,"data Maybe a = Nothing | Just a"
+    ,"data Either a b = Left a | Right b"
+    ,"type Rational = Ratio Integer"
+    ,"data (Integral a) => Ratio a = !a :% !a"
+    ,"type String = [Char]"
+    ] ++
+    listCtor :
+    map tupleDefn (0:[2..32])
+
+listCtor = DataDecl sl  DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
+    [QualConDecl sl [] [] $ ConDecl (Ident "[]") []
+    ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [tyVar "a", TyList $ tyVar "a"]] []
+
+tupleDefn :: Int -> Decl
+tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map tyVar vars)] []
+    where s = "(" ++ replicate (n - 1) ',' ++ ")"
+          vars = ['v':show i | i <- [1..n]]
diff --git a/src/Data/Derive/UniplateTypeable.hs b/src/Data/Derive/UniplateTypeable.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/UniplateTypeable.hs
@@ -0,0 +1,73 @@
+module Data.Derive.UniplateTypeable where
+{-
+import "uniplate" Data.Generics.Uniplate.Typeable
+
+example :: Custom
+
+instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where
+    plateAll (First) = plate First
+    plateAll (Second x1 x2)  = plate Second |+ x1 |+ x2
+    plateAll (Third x1) = plate Third |+ x1
+
+test :: Bool
+
+instance (Typeable to, Uniplate to) => PlateAll Bool to where
+    plateAll False = plate False
+    plateAll True = plate True
+
+test :: Either a b
+
+instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where
+    plateAll (Left x1) = plate Left |+ x1
+    plateAll (Right x1) = plate Right |+ x1
+
+-}
+
+import Data.Derive.DSL.HSE
+
+-- GENERATED START
+
+import Data.Derive.DSL.DSL
+import Data.Derive.Internal.Derivation
+
+makeUniplateTypeable :: Derivation
+makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $
+    List [App "InstDecl" (List [App "Nothing" (List []),List [],List [
+    App "ClassA" (List [App "UnQual" (List [App "Ident" (List [String
+    "Typeable"])]),List [App "TyVar" (List [App "Ident" (List [String
+    "a"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" (
+    List [String "PlateAll"])]),List [App "TyVar" (List [App "Ident" (
+    List [String "a"])]),App "TyVar" (List [App "Ident" (List [String
+    "to"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" (
+    List [String "Uniplate"])]),List [App "TyVar" (List [App "Ident" (
+    List [String "to"])])]]),App "ClassA" (List [App "UnQual" (List [
+    App "Ident" (List [String "Typeable"])]),List [App "TyVar" (List [
+    App "Ident" (List [String "to"])])]])],App "UnQual" (List [App
+    "Ident" (List [String "PlateAll"])]),List [App "TyParen" (List [
+    App "TyApp" (List [App "TyCon" (List [App "UnQual" (List [App
+    "Ident" (List [DataName])])]),App "TyVar" (List [App "Ident" (List
+    [String "a"])])])]),App "TyVar" (List [App "Ident" (List [String
+    "to"])])],List [App "InsDecl" (List [App "FunBind" (List [MapCtor
+    (App "Match" (List [App "Ident" (List [String "plateAll"]),List [
+    App "PParen" (List [App "PApp" (List [App "UnQual" (List [App
+    "Ident" (List [CtorName])]),MapField (App "PVar" (List [App
+    "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]
+    )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App
+    "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App
+    "Symbol" (List [String "|+"])])]),Head])) (Concat (List [Reverse (
+    MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [
+    Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App
+    "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (
+    List [String "plate"])])]),App "Con" (List [App "UnQual" (List [
+    App "Ident" (List [CtorName])])])])]]))]),App "Nothing" (List [])]
+    ))])])]])]
+-- GENERATED STOP
+
+
+custom (_,d) [InstDecl x1 x2 x3 _ x5 _ x7] = [InstDecl x1 x2 x3 x4 x5 x6 x7]
+    where
+        vars = dataDeclVars d
+        dd = (if null vars then id else TyParen) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)
+        x4 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]
+        x6 = [dd, tyVar "to"]
+        f v = [ClassA (qname "Typeable") [tyVar v], ClassA (qname "PlateAll") [tyVar v, tyVar "to"]]
diff --git a/src/Data/Derive/Update.hs b/src/Data/Derive/Update.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Derive/Update.hs
@@ -0,0 +1,47 @@
+{-|
+    A Pseudo derivation. For every label, creates a function
+    foo_u and foo_s which updates and sets the label respectively,
+    e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'
+-}
+module Data.Derive.Update(makeUpdate) where
+
+{-
+
+test :: Computer
+
+speed_u :: (Int -> Int) -> Computer -> Computer
+speed_u f x = x{speed = f (speed x)}
+
+speed_s :: Int -> Computer -> Computer
+speed_s v x = x{speed = v}
+
+weight_u :: (Double -> Double) -> Computer -> Computer
+weight_u f x = x{weight = f (weight x)}
+
+weight_s :: Double -> Computer -> Computer
+weight_s v x = x{weight = v}
+
+test :: Sample
+
+-}
+
+import Language.Haskell
+import Data.Derive.Internal.Derivation
+import Data.Maybe
+
+
+makeUpdate :: Derivation
+makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d
+
+
+makeUpdateField :: DataDecl -> String -> [Decl]
+makeUpdateField d field =
+        [TypeSig sl [name upd] (TyParen (TyFun typF typF) `TyFun` typR)
+        ,bind upd [pVar "f",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (App (var "f") (Paren $ App (var field) (var "x")))]
+        ,TypeSig sl [name set] (typF `TyFun` typR)
+        ,bind set [pVar "v",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]]
+    where
+        set = field ++ "_s"
+        upd = field ++ "_u"
+        typR = dataDeclType d `TyFun` dataDeclType d
+        typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
diff --git a/src/Data/DeriveDSL.hs b/src/Data/DeriveDSL.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DeriveDSL.hs
@@ -0,0 +1,21 @@
+
+module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where
+
+import Data.Derive.DSL.Derive
+import Data.Derive.DSL.Apply
+import Data.Derive.DSL.DSL
+import Data.Derive.DSL.HSE
+import Data.Derive.DSL.SYB
+import Data.Maybe
+
+
+deriveDSL :: [Decl] -> Maybe DSL
+deriveDSL = listToMaybe . derive
+
+
+applyDSL :: DSL -> DataDecl -> Either String [Decl]
+applyDSL dsl inp = Right $ apply dsl $ toInput inp
+
+
+dynamicDSL :: DSL -> Maybe [Decl]
+dynamicDSL = dslSYB
diff --git a/src/Data/DeriveMain.hs b/src/Data/DeriveMain.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DeriveMain.hs
@@ -0,0 +1,19 @@
+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Needed for Haddock docs
+
+-- | Use this module to create your own derive program, supporting custom derivations.
+--   As an example:
+--
+-- @
+--   import "Data.DeriveMain"        ('deriveMain')
+--   import "Data.Derive.All"        ('derivations')
+--   import MyProject.MyDerivation (myDerivation)
+-- @
+--
+-- @
+--   main :: IO
+--   main = 'deriveMain' $ [myDerivation] ++ 'derivations'
+-- @
+module Data.DeriveMain(deriveMain) where
+
+import Derive.Main
+import Data.Derive.All(derivations)
diff --git a/src/Data/DeriveTH.hs b/src/Data/DeriveTH.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/DeriveTH.hs
@@ -0,0 +1,44 @@
+-- | The main TH driver module.  It is intended that this need be the
+-- only module imported by user code; it takes care of all data
+-- threading issues such that all one needs to do is:
+--
+-- @
+--   data Foo = Foo ; $( derive makeEq ''Foo )
+-- @
+module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where
+
+import Control.Monad
+
+import Data.Derive.All
+import Data.Derive.Internal.Derivation
+import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)
+import Language.Haskell as HS
+import Language.Haskell.Convert
+
+
+-- | Derive an instance of some class. @derive@ only derives instances
+-- for the type of the argument.
+derive :: Derivation -> TH.Name -> Q [Dec]
+derive d name = do
+    x <- reify name
+    case x of
+        TyConI dec -> deriveFromDec d dec
+        _ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x
+
+
+derives :: [Derivation] -> [TH.Name] -> Q [Dec]
+derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]
+
+
+-- | Derive an instance of some class. @deriveFromDec@ only derives instances
+-- for the type of the argument.
+deriveFromDec :: Derivation -> Dec -> Q [Dec]
+deriveFromDec d x = do
+    x <- liftM normData $ expandData x
+    let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x
+    case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of
+        Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []
+        Right v -> return $ convert v
+
+toFullDataDecl :: Dec -> FullDataDecl
+toFullDataDecl x = (ModuleName "Todo", convert x)
diff --git a/src/Derive/Derivation.hs b/src/Derive/Derivation.hs
new file mode 100644
--- /dev/null
+++ b/src/Derive/Derivation.hs
@@ -0,0 +1,100 @@
+
+module Derive.Derivation(wantDerive, performDerive, writeDerive) where
+
+import System.IO
+import System.IO.Unsafe
+import Language.Haskell
+import Control.Arrow
+import Control.Monad
+import Data.List
+import Derive.Utils
+import Derive.Flags
+import Data.Derive.Internal.Derivation
+import qualified Data.Map as Map
+
+
+---------------------------------------------------------------------
+-- WHAT DO YOU WANT TO DERIVE
+
+wantDerive :: [Flag] -> Module -> Module -> [Type]
+wantDerive flag real mine = nub $ map fromTyParens $ wantDeriveFlag flag decls ++ wantDeriveAnnotation real mine
+    where decls = filter isDataDecl $ moduleDecls mine
+
+
+wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type]
+wantDeriveFlag flags decls = [TyApp (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]
+    where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]
+
+wantDeriveAnnotation :: Module -> Module -> [Type]
+wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real
+
+
+moduleDerives :: Module -> [Type]
+moduleDerives = concatMap f . moduleDecls 
+    where
+        f (DataDecl _ _ _ name vars _ deriv) = g name vars deriv
+        f (GDataDecl _ _ _ name vars _ _ deriv) = g name vars deriv
+        f (DerivDecl _ _ _ _ name args) = [TyCon name `tyApps` args]
+        f _ = []
+
+        g name vars deriv = [TyCon a `tyApps` (b:bs) | (a,bs) <- deriv]
+            where b = TyCon (UnQual name) `tyApps` map (tyVar . prettyPrint) vars
+
+
+---------------------------------------------------------------------
+-- ACTUALLY DERIVE IT
+
+performDerive :: [Derivation] -> Module -> [Type] -> [String]
+performDerive derivations modu = concatMap ((:) "" . f)
+    where
+        grab = getDecl modu
+
+        g = getDerivation derivations
+        f ty = case d ty grab (moduleName modu, grab typ1Name) of
+                Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]
+                Right x -> concatMap (lines . prettyPrint) x
+            where
+                d = derivationOp $ g clsName
+                (cls,typ1:_) = fromTyApps ty
+                clsName = prettyPrint cls
+                typ1Name = tyRoot typ1
+                msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x
+
+
+getDecl :: Module -> (String -> Decl)
+getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp
+    where
+        mp = Map.fromList $ concatMap f $ moduleDecls modu
+        f x@(DataDecl _ _ _ name _ _ _) = [(prettyPrint name, x)]
+        f x@(GDataDecl _ _ _ name _ _ _ _) = [(prettyPrint name, x)]
+        f x@(TypeDecl _ name _ _) = [(prettyPrint name, x)]
+        f _ = []
+
+
+getDerivation :: [Derivation] -> String -> Derivation
+getDerivation derivations = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp
+    where
+        mp = Map.fromList $ map (derivationName &&& id) derivations
+
+
+---------------------------------------------------------------------
+-- WRITE IT BACK
+
+writeDerive :: FilePath -> ModuleName -> [Flag] -> [String] -> IO ()
+writeDerive file modu flags xs = do
+    -- force the output first, ensure that we don't crash half way through
+    () <- length (concat xs) `seq` return ()
+    
+    let append = Append `elem` flags
+    let output = [x | Output x <- flags]
+
+    let ans = take 1 ["module " ++ x ++ " where" | Modu x <- reverse flags] ++
+              ["import " ++ if null i then prettyPrint modu else i | Import i <- flags] ++
+              xs
+
+    when append $ do
+        src <- readFile' file
+        writeGenerated file ans
+
+    forM output $ \o -> writeFile o $ unlines ans
+    when (not append && null output) $ putStr $ unlines ans
diff --git a/src/Derive/Flags.hs b/src/Derive/Flags.hs
new file mode 100644
--- /dev/null
+++ b/src/Derive/Flags.hs
@@ -0,0 +1,65 @@
+
+module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where
+
+import System.Environment
+import System.Console.GetOpt
+import System.Directory
+import Language.Haskell
+import System.Exit
+import System.IO
+import Data.Maybe
+
+
+data Flag = Version | Help | Output String | Import String | Modu String
+          | Append | Derive [String] | NoOpts | Preprocessor | Test | Generate
+            deriving (Eq, Show)
+
+
+options :: [OptDescr Flag]
+options =
+    [Option "v"  ["version"]  (NoArg Version)          "show version number"
+    ,Option "h?" ["help"]     (NoArg Help)             "show help message"
+    ,Option "o"  ["output"]   (ReqArg Output "FILE")   "output FILE"
+    ,Option "i"  ["import"]   (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"
+    ,Option "m"  ["module"]   (ReqArg Modu "MODULE")   "add a module MODULE where statement"
+    ,Option "a"  ["append"]   (NoArg Append)           "append the result to the file"
+    ,Option "d"  ["derive"]   (ReqArg splt "DERIVES")  "things to derive for all types"
+    ,Option "n"  ["no-opts"]  (NoArg NoOpts)           "ignore the file options"
+    ,Option "F"  ["preprocessor"] (NoArg Preprocessor) "operate as a GHC preprocessor with -pgmF"
+    ,Option ""   ["test"]     (NoArg Test)             "run the test suite"
+    ,Option ""   ["generate"] (NoArg Generate)         "perform code generation"
+    ]
+    where splt = Derive . words . map (\x -> if x == ',' then ' ' else x)
+
+
+flagInfo = usageInfo "Usage: derive [OPTION...] files..." options
+
+
+getFlags :: IO ([Flag], [String])
+getFlags = do
+    args <- getArgs
+    case getOpt Permute options args of
+        (o,n,[]  ) | Version `elem` o -> putStrLn "Derive 2.5.* (C) Neil Mitchell 2006-2013" >> exitSuccess
+                   | Help `elem` o    -> putStr flagInfo >> exitSuccess
+                   | Preprocessor `elem` o -> return (o,n)
+                   | otherwise        -> do files <- mapM pickFile n; return (o, files)
+        (_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure
+    where
+        exitSuccess = exitWith ExitSuccess
+
+
+pickFile :: FilePath -> IO FilePath
+pickFile orig = f [orig, orig ++ ".hs", orig ++ ".lhs"]
+    where
+        f [] = error $ "File not found: " ++ orig
+        f (x:xs) = do
+            b <- doesFileExist x
+            if b then return x else f xs
+
+
+addFlags :: [Flag] -> (SrcLoc, [String]) -> [Flag]
+addFlags flags (sl,xs)
+    | NoOpts `elem` flags = flags
+    | errs /= [] = error $ prettyPrint sl ++ "\n" ++ concat errs
+    | otherwise = flags ++ a
+    where (a,_,errs) = getOpt Permute options xs
diff --git a/src/Derive/Generate.hs b/src/Derive/Generate.hs
new file mode 100644
--- /dev/null
+++ b/src/Derive/Generate.hs
@@ -0,0 +1,115 @@
+
+module Derive.Generate(generate) where
+
+import Language.Haskell.Exts
+import Data.DeriveDSL
+import Derive.Utils
+import Control.Monad
+import Data.Maybe
+import System.FilePath
+import System.Directory
+import Data.Char
+import Data.List
+
+
+evil = words "TTypeable Uniplate"
+
+-- generate extra information for each derivation
+generate :: IO ()
+generate = do
+    xs <- getDirectoryContents "src/Data/Derive"
+    xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]
+    lis <- mapM generateFile $ map ("src/Data/Derive" </>) xs
+    let names = map dropExtension xs
+        n = maximum $ map length names
+    writeGenerated "src/Data/Derive/All.hs" $
+        ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++
+        ["derivations :: [Derivation]"
+        ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]
+    writeGenerated "README.md" $ ["-->",""] ++ lis ++ ["","<!--"]
+    writeGenerated "derive.cabal" $ map ("        Data.Derive."++) names
+
+
+-- return the Documentation string
+generateFile :: FilePath -> IO String
+generateFile file = do
+    let name = takeBaseName file
+    putStrLn $ "Generating " ++ name
+    src <- readSrc file
+    when (isJust $ srcExample src) $ do
+        let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $
+                            deriveDSL $ fromJust $ srcExample src
+        writeGenerated file $
+            [""
+            ,"import Data.Derive.DSL.DSL"
+            ,"import Data.Derive.Internal.Derivation"
+            ,""
+            ,"make" ++ name ++ " :: Derivation"
+            ] ++ (if srcCustom src then
+                ["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]
+            else
+                ["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name
+                ,""
+                ,"dsl" ++ name ++ " ="
+            ]) ++
+            map (replicate 4 ' ' ++) (wrap 66 $ show dsl)
+
+
+        let inst = dynamicDSL dsl
+            instFile = takeDirectory file </> "Instance" </> name <.> "hs"
+        b <- doesFileExist instFile
+        if not (srcCustom src) && isJust inst then do
+            writeGenerated instFile $
+                ["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] ++
+                ["","module Data.Derive.Instance." ++ name ++ " where",""] ++
+                (map prettyPrint $ srcImportStd src) ++
+                ["import Data.Derive.Internal.Instance",""] ++
+                (map prettyPrint $ fromJust inst) ++ [""]
+         else when b $
+            error $ "Previously generated dynamic instance can not be regenerated, " ++ name
+
+    let imp = listToMaybe $ srcImport src
+    return $
+        "* **[" ++ name ++ "](" ++ instUrl name imp ++ ")**" ++
+        concat [" - from the library [" ++ pkg ++ "](" ++ pkgUrl pkg ++ ")" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp]
+
+pkgUrl x = "http://hackage.haskell.org/package/" ++ x
+
+instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"
+instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam
+    where
+        (a,b) = break (== '-') $ fromMaybe "base" $ importPkg x
+        pkgName = a
+        pkgVersion = if null b then "latest" else tail b
+        modu = reps '.' '-' $ prettyPrint $ importModule x
+        nam = case importSpecs x of Just (False,IAbs _ y:_) -> prettyPrint y ; _ -> name
+
+
+wrap :: Int -> String -> [String]
+wrap n = f . lexemes
+    where
+        f [] = []
+        f (x:xs) = [reverse $ dropWhile isSpace $ reverse $ concat $ x:a] ++ f (dropWhile (all isSpace) b)
+            where (a,b) = thisLine (n - length x) xs
+
+        thisLine i [] = ([], [])
+        thisLine i (x:xs) | j > i = ([], x:xs)
+                          | otherwise = (x:a, b)
+            where j = length x
+                  (a,b) = thisLine (i - j) xs
+
+
+lexemes :: String -> [String]
+lexemes [] = []
+lexemes x = a : lexemes b
+    where (a,b) = lexeme x 
+
+
+lexeme :: String -> (String, String)
+lexeme xs@(x:_) | isAlpha x = span isAlpha xs
+lexeme ('\"':xs) = let (a,b) = f xs in ('\"':a,b)
+    where f ('\\':x:xs) = let (a,b) = f xs in ('\\':x:a,b)
+          f ('\"':xs) = ("\"",xs)
+          f (x:xs) = let (a,b) = f xs in (x:a,b)
+          f [] = ([],[])
+lexeme (x:xs) = ([x], xs)
diff --git a/src/Derive/Main.hs b/src/Derive/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Derive/Main.hs
@@ -0,0 +1,63 @@
+
+module Derive.Main(deriveMain) where
+
+import Language.Haskell
+import Data.Derive.All(Derivation)
+import Derive.Derivation
+import Derive.Generate
+import Derive.Test
+import Derive.Flags
+import Data.List
+import System.Directory
+
+
+deriveMain :: [Derivation] -> IO ()
+deriveMain derivations = do
+    (flags,files) <- getFlags
+    if Test `elem` flags then
+        test
+     else if Generate `elem` flags then
+        generate
+     else if Preprocessor `elem` flags then
+        (if length files /= 3 then
+            error $ "Expected to be invoked as a GHC preprocessor with 3 files, but got " ++ show (length files)
+         else do
+            copyFile (files !! 1) (files !! 2)
+            mainFile derivations (Append:flags) (files !! 2)
+         )
+     else if null files then
+        putStr $ "No files specified\n" ++ flagInfo
+     else
+        mapM_ (mainFile derivations flags) files
+
+
+mainFile :: [Derivation] -> [Flag] -> FilePath -> IO ()
+mainFile derivations flags file = do
+    src <- readFile file
+    src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src
+    let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions}
+        real = parse src
+        mine = parse $ uncomment src
+    flags <- return $ foldl addFlags flags
+        [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]
+    let res = performDerive derivations mine $ wantDerive flags real mine
+    writeDerive file (moduleName mine) flags res
+
+
+uncomment :: String -> String
+uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs
+uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs
+uncomment (x:xs) = x:uncomment xs
+uncomment [] = []
+
+
+-- Taken from HLint, update occasionally
+defaultExtensions :: [Extension]
+defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions
+
+badExtensions =
+    [Arrows -- steals proc
+    ,TransformListComp -- steals the group keyword
+    ,XmlSyntax, RegularPatterns -- steals a-b
+    ]
+
diff --git a/src/Derive/Test.hs b/src/Derive/Test.hs
new file mode 100644
--- /dev/null
+++ b/src/Derive/Test.hs
@@ -0,0 +1,100 @@
+
+module Derive.Test(test) where
+
+import Derive.Utils
+import Data.Derive.DSL.HSE
+import Control.Monad
+import Data.Maybe
+import Data.List
+import System.FilePath
+import System.Process
+import System.Exit
+import Control.Arrow
+import Data.Derive.All
+import Data.Derive.Internal.Derivation
+
+
+-- These overlap with other derivations
+overlaps =
+    [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]
+    ,["Serialize"]]
+
+-- REASONS:
+-- UniplateDirect: Doesn't work through Template Haskell
+-- Typeable cannot be separately derived in GHC 7.8
+exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]
+
+-- These must be first and in every set
+priority = ["Eq"]
+
+
+listType :: Decl
+listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]
+    [QualConDecl sl [] [] (ConDecl (Ident "[]") [])
+    ,QualConDecl sl [] [] (ConDecl (Ident "Cons")
+        [TyVar (Ident "a")
+        ,TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a"))])]
+    []
+
+
+-- test each derivation
+test :: IO ()
+test = do
+    decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"
+
+    -- check the test bits
+    let ts = ("[]",listType) : map (dataDeclName &&& id) decls
+    mapM_ (testFile ts) derivations
+
+    -- check the $(derive) bits
+    putStrLn "Type checking examples"
+    let name = "AutoGenerated_Test"
+    devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]
+    let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs
+
+    let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $
+            [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps
+
+    forM sets $ \(i,xs) -> autoTest (name++show i) decls xs
+    writeFile (name++".hs") $ unlines $
+        ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]
+    res <- system $ "runhaskell -isrc " ++ name ++ ".hs"
+    when (res /= ExitSuccess) $ error "Failed to typecheck results"
+
+
+testFile :: [(String,Decl)] -> Derivation -> IO ()
+testFile types (Derivation name op) = do
+    putStrLn $ "Testing " ++ name
+    src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"
+    forM_ (srcTest src) $ \(typ,res) -> do
+        let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ
+        let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types
+        let Right r = op typ grab (ModuleName "Example", grab d)
+        when (not $ r `outEq` res) $
+            error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r
+
+detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb
+    where na = length as ; nb = length bs
+
+detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b
+    where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)
+
+
+autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()
+autoTest name ts ds =
+    writeFile (name++".hs") $ unlines $
+        ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators,DeriveDataTypeable #-}"
+        ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"
+        ,"module " ++ name ++ " where"
+        ,"import Prelude"
+        ,"import Data.DeriveTH"
+        ,"import Data.Typeable"
+        ,"import Derive.TestInstances()"] ++
+        [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++
+        [prettyPrint t ++ "\n  deriving Typeable" | t <- ts2] ++
+        ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]
+    where
+        types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"
+        ts2 = filter (not . isBuiltIn) ts
+
+isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
diff --git a/src/Derive/Utils.hs b/src/Derive/Utils.hs
new file mode 100644
--- /dev/null
+++ b/src/Derive/Utils.hs
@@ -0,0 +1,86 @@
+
+module Derive.Utils where
+
+import Data.Derive.DSL.HSE
+import Data.List
+import qualified Data.ByteString.Char8 as BS
+import System.Directory
+import System.IO
+import System.FilePath
+import Control.Monad
+import Data.Maybe
+
+
+data Src = Src
+    {srcName :: String
+    ,srcImport :: [ImportDecl]
+    ,srcExample :: Maybe [Decl]
+    ,srcTest :: [(Type,[Decl])]
+    ,srcCustom :: Bool
+    }
+
+-- skip the importPkg bits
+srcImportStd :: Src -> [ImportDecl]
+srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]
+
+nullSrc = Src "" [] Nothing [] False
+
+
+readHSE :: FilePath -> IO Module
+readHSE file = do
+    src <- readFile' file
+    src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $
+                    dropWhile (not . isPrefixOf "module ") $ lines src
+
+    let mode = defaultParseMode{extensions=map EnableExtension [MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}
+    return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src
+
+
+data Pragma = Example Bool | Test Type
+
+asPragma :: Decl -> Maybe Pragma
+asPragma (TypeSig _ [x] t)
+    | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"
+    | x ~= "test" = Just $ Test t
+asPragma _ = Nothing
+
+
+readSrc :: FilePath -> IO Src
+readSrc file = do
+    modu <- readHSE file
+    return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}
+        [ (p,xs)
+        | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]
+        , let xs = takeWhile (isNothing . asPragma) real ]
+    where
+        f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}
+        f src (Test    x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}
+
+
+generatedStart = "-- GENERATED START"
+generatedStop  = "-- GENERATED STOP"
+
+
+
+writeGenerated :: FilePath -> [String] -> IO ()
+writeGenerated file x = do
+    src <- fmap lines $ readFile' file
+    let pre = takeWhile (/= generatedStart) src
+        post = drop 1 $ dropWhile (/= generatedStop) src
+        src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post
+    when (src /= src2) $
+        seq (length src2) $ writeBinaryFile file $ unlines src2
+
+
+readFile' :: FilePath -> IO String
+readFile' file = do
+    b <- doesFileExist file
+    if b then fmap BS.unpack $ BS.readFile file else return []
+
+
+writeBinaryFile :: FilePath -> String -> IO ()
+writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)
+
+
+rep from to x = if x == from then to else x
+reps from to = map (rep from to)
diff --git a/src/Language/Haskell.hs b/src/Language/Haskell.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell.hs
@@ -0,0 +1,300 @@
+
+module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where
+
+import Language.Haskell.Exts hiding (var,app,binds,paren)
+import Data.List
+import Data.Generics.Uniplate.Data
+import Data.Data
+import Data.Char
+import Data.Maybe
+
+
+infix 1 ?
+True ? b = const b
+False ? b = id
+
+
+
+-- insert explicit foralls
+foralls :: Type -> Type
+foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x
+
+
+tyApps x [] = x
+tyApps x (y:ys) = tyApps (TyApp x y) ys
+
+
+fromTyApps (TyTuple _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)
+fromTyApps (TyApp x y) = let (a,b) = fromTyApps x in (a, b ++ [y])
+fromTyApps (TyList x) = (TyCon $ Special ListCon, [x])
+fromTyApps x = (x, [])
+
+fromTyTuple (TyTuple _ xs) = xs
+fromTyTuple x = [x]
+
+fromTyParen (TyParen x) = fromTyParen x
+fromTyParen x = x
+
+fromTyParens = transform fromTyParen
+
+tyRoot = prettyPrint . fst . fromTyApps . fromTyParen
+
+isTyFun TyFun{} = True
+isTyFun _ = False
+
+isTyParen TyParen{} = True ; isTyParen _ = False
+
+fromTyList (TyList x) = Just x
+fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x
+fromTyList x = Nothing
+
+
+x ~= y = prettyPrint x == y
+
+
+appP x@App{} y = App x y
+appP x y = App (paren x) (paren y)
+
+
+simplify :: Data a => a -> a
+simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp
+    where
+        fExp (App op (List xs))
+            | op ~= "length" = Lit $ Int $ fromIntegral $ length xs
+            | op ~= "head" = head xs
+            | op ~= "null" = con $ show $ null xs
+        fExp (InfixApp (Lit (Int i)) op (Lit (Int j)))
+            | op ~= "-" = Lit $ Int $ i - j
+            | op ~= "+" = Lit $ Int $ i + j
+            | op ~= ">" = Con $ UnQual $ Ident $ show $ i > j
+        fExp (InfixApp x op y)
+            | op ~= "`const`" = x
+            | op ~= "&&" && y ~= "True" = x
+            | x ~= "id" && op ~= "." = y
+            | y ~= "id" && op ~= "." = x
+        fExp (InfixApp (Lit (String x)) op (Lit (String y))) | op ~= "++" = Lit $ String $ x ++ y
+        fExp (App (App (App flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x        
+        fExp (App (Paren x@App{}) y) = fExp $ App x y
+        fExp (App (Paren (InfixApp x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z
+        fExp (App op x) | op ~= "id" = x
+        fExp (App (App flp con) x) | flp ~= "flip" && con ~= "const" = var "id"
+        fExp (App (App con x) y) | con ~= "const" = x
+        fExp (App choose (Tuple _ [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App (var "return") x
+        fExp (App op x) | op ~= "id" = x
+        fExp (InfixApp (App when true) dot res)
+            | when ~= "when" && true ~= "True" = res
+        fExp (InfixApp x y z) | y ~= "++" && z ~= "[]" = x
+        fExp (App (LeftSection x op) y) = fExp $ InfixApp x op (paren y)
+        fExp (Paren x) | isAtom x = x
+        fExp (Do [Qualifier x]) = x
+        fExp (Do (Qualifier (App ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do xs
+        fExp (Do (Generator _ (PVar x) (App ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do $ subst x2 y xs
+            where x2 = Var $ UnQual x
+        fExp (Case (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case x alts
+        fExp (Case (Lit x) alts) | good /= [] = head good
+            where good = [z | Alt _ (PLit Signless y) (UnGuardedRhs z) Nothing <- alts, y == x]
+        fExp (If x t f)
+            | x ~= "True" = t
+            | x ~= "False" = f
+        fExp (App (App when b) x)
+            | when ~= "when" && b ~= "True" = x
+            | when ~= "when" && b ~= "False" = App (Var $ UnQual $ Ident "return") (Con $ Special $ TupleCon Boxed 0)
+        fExp (App (Paren (Lambda _ [PVar x] y)) z) | once x2 y = fExp $ subst x2 z y
+            where x2 = Var $ UnQual x
+        fExp (App (Paren (Lambda _ [PWildCard] x)) _) = x
+        fExp (Lambda s ps x) = Lambda s (minPat x ps) x
+        fExp (Con x) = Con $ rename x
+        fExp x = x
+
+        fTyp (TyApp x y) | x ~= "[]" = TyList y
+        fTyp (TyApp (TyCon (Special ListCon)) x) = TyList x
+        fTyp (TyParen x@TyCon{}) = x
+        fTyp (TyParen x@TyVar{}) = x
+        fTyp (TyParen x@TyList{}) = x
+        fTyp (TyCon nam) = TyCon $ rename nam
+        fTyp x = x
+
+        fPat (PParen x@(PApp _ [])) = x
+        fPat (PParen (PParen x)) = PParen x
+        fPat (PApp nam xs) = case rename nam of
+            Special (TupleCon Boxed _) -> PTuple Boxed xs
+            nam -> PApp nam xs
+        fPat (PParen (PTuple l xs)) = PTuple l xs
+        fPat x = x
+
+        fMatch (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls)
+            | x ~= "True" = fMatch $ Match sl nam pat sig (UnGuardedRhs bod) decls
+        fMatch (Match sl nam [PVar x] sig (UnGuardedRhs (Case (Var (UnQual x2)) [Alt _ pat (UnGuardedRhs y) Nothing])) decls)
+            | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls
+        fMatch o@(Match a b c d e bind) = fBinds (Match a b (minPat o c) d e) bind
+
+        fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind
+        fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs
+        fDecl x = x
+
+        fBinds context Nothing = context Nothing
+        fBinds context (Just (BDecls bind)) | inline /= [] =
+                simplify $ subst (Var $ UnQual from) to $ context $
+                    let xs = take i bind ++ drop (i+1) bind in if null xs then Nothing else Just $ BDecls xs
+            where
+                f (PatBind _ (PVar x) (UnGuardedRhs bod) Nothing) = [(x,bod)]
+                f (FunBind [Match _ x [PVar v] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) Nothing])
+                    | UnQual v == v2 = [(x,bod)]
+                f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) Nothing]) = [(x,Paren $ Lambda sl pat bod)]
+                f _ = []
+
+                (i,from,to) = head inline
+                inline = [(i, x, bod)
+                         | (i,b) <- zip [0..] bind, (x,bod) <- f b
+                         , isAtom bod || once (Var $ UnQual x) (context $ Just $ BDecls bind)]
+        fBinds a y = a y
+
+        subst from to = transformBi $ \x -> if x == from then to else x
+        once x y = length (filter (== x) (universeBi y)) <= 1  
+
+        minPat o ps = transformBi f ps
+            where
+                known = nub [x | UnQual x <- universeBi o]
+                f (PVar x) | x `notElem` known = PWildCard
+                f (PAsPat x y) | x `notElem` known = y
+                f x = x
+
+
+
+isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False"
+isGuardFalse _ = False
+
+
+rename (UnQual (Ident ('(':xs@(x:_))))
+    | x == ',' = Special $ TupleCon Boxed $ length xs
+    | x /= ')' = UnQual $ Symbol $ init xs
+rename x = x
+
+
+isAtom Con{} = True
+isAtom Var{} = True
+isAtom Lit{} = True
+isAtom Paren{} = True
+isAtom _ = False
+
+
+paren x = if isAtom x then x else Paren x
+
+sl = SrcLoc "" 0 0
+
+noSl mr = transformBi (const sl) mr
+
+
+isIdent (x:xs) = isAlpha x || x == '_'
+title (x:xs) = toUpper x : xs
+
+qname = UnQual . name
+var = Var . qname
+con = Con . qname
+tyVar = TyVar . name
+tyVarBind = UnkindedVar . name
+tyCon = TyCon . qname
+pVar = PVar . name
+qvop = QVarOp . UnQual . Symbol
+
+dataDeclType :: DataDecl -> Type
+dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)
+
+dataDeclFields :: DataDecl -> [String]
+dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors
+
+
+-- A declaration that is either a DataDecl of GDataDecl
+type DataDecl = Decl
+type CtorDecl = Either QualConDecl GadtDecl
+type FieldDecl = [(String, Type)]
+
+type FullDataDecl = (ModuleName, DataDecl)
+
+
+moduleName (Module _ name _ _ _ _ _) = name
+moduleDecls (Module _ _ _ _ _ _ decls) = decls
+moduleImports (Module _ _ _ _ _ imps _) = imps
+modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas
+
+
+showDecls x = unlines $ map prettyPrint x
+
+
+tyApp x [] = x
+tyApp x xs = TyApp (tyApp x $ init xs) (last xs)
+
+
+tyFun [x] = x
+tyFun (x:xs) = TyFun x (tyFun xs)
+
+
+apps x [] = x
+apps x (y:ys) = apps (App x y) ys
+
+
+bind :: String -> [Pat] -> Exp -> Decl
+bind s p e = binds s [(p,e)]
+
+binds :: String -> [([Pat], Exp)] -> Decl
+binds n [([],e)] = PatBind sl (pVar n) (UnGuardedRhs e) Nothing
+binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) Nothing | (p,e) <- xs]
+
+
+isDataDecl :: Decl -> Bool
+isDataDecl DataDecl{} = True
+isDataDecl GDataDecl{} = True
+isDataDecl _ = False
+
+
+dataDeclSrcLoc :: DataDecl -> SrcLoc
+dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl
+dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl
+
+dataDeclContext :: DataDecl -> Context
+dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx
+dataDeclContext _ = error "dataDeclContext: not a DataDecl"
+
+dataDeclName :: DataDecl -> String
+dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name
+dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
+
+dataDeclVars :: DataDecl -> [String]
+dataDeclVars (DataDecl _ _ _ _ vars _ _) = map f vars
+    where f (KindedVar x _) = prettyPrint x
+          f (UnkindedVar x) = prettyPrint x
+
+dataDeclVarsStar :: DataDecl -> [String]
+dataDeclVarsStar (DataDecl _ _ _ _ vars _ _) = mapMaybe f vars
+    where f (UnkindedVar x) = Just $ prettyPrint x
+          f (KindedVar x KindStar) = Just $ prettyPrint x
+          f _ = Nothing
+
+dataDeclArity :: DataDecl -> Int
+dataDeclArity = length . dataDeclVars
+
+dataDeclCtors :: DataDecl -> [CtorDecl]
+dataDeclCtors (DataDecl _ _ _ _ _ ctors _) = map Left ctors
+
+
+ctorDeclName :: CtorDecl -> String
+ctorDeclName = prettyPrint . ctorDeclName'
+
+ctorDeclName' :: CtorDecl -> Name
+ctorDeclName' (Left (QualConDecl _ _ _ (ConDecl name _))) = name
+ctorDeclName' (Left (QualConDecl _ _ _ (InfixConDecl _ name _))) = name
+ctorDeclName' (Left (QualConDecl _ _ _ (RecDecl name _))) = name
+
+ctorDeclFields :: CtorDecl -> FieldDecl
+ctorDeclFields (Left (QualConDecl _ _ _ (ConDecl name fields))) = map ((,) "") fields
+ctorDeclFields (Left (QualConDecl _ _ _ (InfixConDecl x1 name x2))) = map ((,) "") [x1,x2]
+ctorDeclFields (Left (QualConDecl _ _ _ (RecDecl name fields))) = [(prettyPrint a, b) | (as,b) <- fields, a <- as]
+
+ctorDeclArity :: CtorDecl -> Int
+ctorDeclArity = length . ctorDeclFields
+
+declName :: Decl -> String
+declName (DataDecl _ _ _ name _ _ _) = prettyPrint name
+declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name
+declName (TypeDecl _ name _ _) = prettyPrint name
+
diff --git a/src/Language/Haskell/Convert.hs b/src/Language/Haskell/Convert.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/Convert.hs
@@ -0,0 +1,310 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}
+
+module Language.Haskell.Convert(Convert, convert) where
+
+import Language.Haskell as HS
+import Language.Haskell.TH.Syntax as TH
+import Control.Exception
+import Data.Typeable
+import System.IO.Unsafe
+import Data.Maybe
+
+
+class (Typeable a, Typeable b, Show a, Show b) => Convert a b where
+    conv :: a -> b
+
+
+convert :: forall a b . Convert a b => a -> b
+convert a = unsafePerformIO $
+        (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)
+    where
+        msg e = "Could not convert " ++ show (typeOf a) ++ " to " ++
+                show (typeOf (undefined :: b)) ++ "\n" ++ show a ++
+                "\n" ++ show e
+
+
+
+appT :: TH.Type -> [TH.Type] -> TH.Type
+appT = foldl AppT
+
+c mr = convert mr
+
+instance Convert a b => Convert [a] [b] where
+    conv = map c
+
+
+
+instance Convert TH.Dec HS.Decl where
+    conv x = case x of
+#if __GLASGOW_HASKELL__ >= 800
+        DataD cxt n vs _ con ds -> f DataType cxt n vs con ds
+        NewtypeD cxt n vs _ con ds -> f NewType cxt n vs [con] ds
+        where
+            f :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl
+            f t cxt n vs con _ = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
+#else
+        DataD cxt n vs con ds -> f DataType cxt n vs con ds
+        NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds
+        where
+            f :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl
+            f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
+#endif
+
+instance Convert TH.Name HS.TyVarBind where
+    conv = UnkindedVar . c
+
+instance Convert TH.Name HS.Name where
+    conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2
+        where x2 = show x
+
+instance Convert TH.Name HS.QName where
+    conv x = if x2 == Ident "[]" then Special ListCon else UnQual x2
+        where x2 = c x
+
+instance Convert TH.Con HS.QualConDecl where
+    conv (ForallC vs cxt x) = QualConDecl sl (c vs) (c cxt) (c x)
+    conv x = QualConDecl sl [] [] (c x)
+
+instance Convert TH.Con HS.ConDecl where
+    conv (NormalC n xs) = ConDecl (c n) (c xs)
+    conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs]
+    conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y)
+
+instance Convert TH.StrictType HS.Type where
+#if __GLASGOW_HASKELL__ >= 800
+    conv (Bang SourceUnpack SourceStrict, x) = TyBang UnpackedTy $ TyBang BangedTy $ c x
+    conv (Bang SourceUnpack NoSourceStrictness, x) = TyBang UnpackedTy $ c x
+    conv (Bang NoSourceUnpackedness SourceStrict, x) = TyBang BangedTy $ c x
+    conv (Bang NoSourceUnpackedness NoSourceStrictness, x) = c x
+#else
+    conv (IsStrict, x) = TyBang BangedTy $ c x
+    conv (NotStrict, x) = c x
+#if __GLASGOW_HASKELL__ >= 704
+    conv (Unpacked, x) = TyBang UnpackedTy $ c x
+#endif
+#endif
+
+instance Convert TH.Type HS.Type where
+    conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t)
+    conv (VarT x) = TyVar $ c x
+    conv (ConT x) | ',' `elem` show x = TyTuple Boxed []
+                  | otherwise = TyCon $ c x
+    conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y)
+    conv (ArrowT) = TyCon $ Special FunCon
+    conv (AppT ListT x) = TyList $ c x
+    conv (ListT) = TyCon $ Special ListCon
+    conv (TupleT _) = TyTuple Boxed []
+    conv (AppT x y) = case c x of
+        TyTuple b xs -> TyTuple b $ xs ++ [c y]
+        x -> TyApp x $ c y
+
+instance Convert TH.Type HS.Asst where
+    conv (ConT x) = ClassA (UnQual $ c x) []
+    conv (AppT x y) = case c x of
+        ClassA a b -> ClassA a (b ++ [c y])
+
+
+
+instance Convert HS.Decl TH.Dec where
+    conv (InstDecl _ _ _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds]
+    conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms)
+    conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds)
+    conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)
+#if __GLASGOW_HASKELL__ >= 800
+    --  ! certainly BROKEN because it ignores contexts
+    conv (DataDecl _ DataType ctx nam typ cs ds) =
+      DataD (c ctx) (c nam) (c typ) Nothing (c cs) [] -- (c (map fst ds))
+    conv (DataDecl _ NewType ctx nam typ [con] ds) =
+      NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds)) 
+#else
+    conv (DataDecl _ DataType ctx nam typ cs ds) =
+      DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds))
+    conv (DataDecl _ NewType ctx nam typ [con] ds) =
+      NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds))
+#endif
+      
+instance Convert HS.QualConDecl TH.Con where
+    conv (QualConDecl _ [] [] con) = c con
+    conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con)
+
+instance Convert HS.ConDecl TH.Con where
+    conv (ConDecl nam typ) = NormalC (c nam) (c typ)
+    conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r)
+    conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs)
+
+instance Convert HS.Type TH.StrictType where
+#if __GLASGOW_HASKELL__ >= 800
+    conv (TyBang BangedTy t) = (Bang NoSourceUnpackedness SourceStrict, c t)
+#else
+    conv (TyBang BangedTy t) = (IsStrict, c t)
+#if __GLASGOW_HASKELL__ >= 704
+    conv (TyBang UnpackedTy t) = (Unpacked, c t)
+#else
+    conv (TyBang UnpackedTy t) = (IsStrict, c t)
+#endif
+#endif
+#if __GLASGOW_HASKELL__ >= 800
+    conv t = (Bang NoSourceUnpackedness NoSourceStrictness, c t)
+#else
+    conv t = (NotStrict, c t)
+#endif
+
+instance Convert ([HS.Name],HS.Type) [TH.VarStrictType] where
+    conv (names,bt) = [(c name,s,t) | name <- names]
+     where (s,t) = c bt
+
+instance Convert HS.Asst TH.Type where
+    conv (InfixA x y z) = c $ ClassA y [x,z]
+    conv (ClassA x y) = appT (ConT $ c x) (c y)
+
+instance Convert HS.Type TH.Type where
+    conv (TyCon (Special ListCon)) = ListT
+    conv (TyCon (Special UnitCon)) = TupleT 0
+    conv (TyParen x) = c x
+    conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)
+    conv (TyVar x) = VarT $ c x
+    conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x
+    conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y)
+    conv (TyList x) = AppT ListT (c x)
+    conv (TyTuple _ x) = appT (TupleT (length x)) (c x)
+    conv (TyApp x y) = AppT (c x) (c y)
+
+instance Convert HS.Name TH.Name where
+    conv = mkName . filter (`notElem` "()") . prettyPrint
+
+instance Convert HS.Match TH.Clause where
+    conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds)
+
+instance Convert HS.Rhs TH.Body where
+    conv (UnGuardedRhs x) = NormalB (c x)
+    conv (GuardedRhss x) = GuardedB (c x)
+
+instance Convert HS.Exp TH.Exp where
+    conv (Con (Special UnitCon)) = TupE []
+    conv (Var x) = VarE (c x)
+    conv (Con x) = ConE (c x)
+    conv (Lit x) = LitE (c x)
+    conv (App x y) = AppE (c x) (c y)
+    conv (Paren x) = c x
+    conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z)
+    conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing
+    conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z)
+    conv (Lambda _ x y) = LamE (c x) (c y)
+    conv (Tuple _ x) = TupE (c x)
+    conv (If x y z) = CondE (c x) (c y) (c z)
+    conv (Let x y) = LetE (c x) (c y)
+    conv (Case x y) = CaseE (c x) (c y)
+    conv (Do x) = DoE (c x)
+    conv (EnumFrom x) = ArithSeqE $ FromR (c x)
+    conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y)
+    conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y)
+    conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)
+    conv (List x) = ListE (c x)
+    conv (ExpTypeSig _ x y) = SigE (c x) (c y)
+    conv (RecConstr x y) = RecConE (c x) (c y)
+    conv (RecUpdate x y) = RecUpdE (c x) (c y) 
+    -- Work around bug 3395, convert to do notation instead
+    conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x]
+
+instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where
+    conv = undefined
+
+instance Convert HS.Binds [TH.Dec] where
+    conv (BDecls x) = c x
+
+instance Convert (Maybe HS.Binds) [TH.Dec] where
+    conv Nothing = []
+    conv (Just x) = c x
+
+instance Convert HS.Pat TH.Pat where
+    conv (PParen x) = c x
+    conv (PLit Signless x) = LitP (c x)
+    conv (PTuple _ x) = TupP (c x)
+    conv (PApp x y) = ConP (c x) (c y)
+    conv (PVar x) = VarP (c x)
+    conv (PInfixApp x y z) = InfixP (c x) (c y) (c z)
+    conv (PIrrPat x) = TildeP (c x)
+    conv (PAsPat x y) = AsP (c x) (c y)
+    conv (PWildCard) = WildP
+    conv (PRec x y) = RecP (c x) (c y)
+    conv (PList x) = ListP (c x)
+    conv (PatTypeSig _ x y) = SigP (c x) (c y)
+
+instance Convert HS.Literal TH.Lit where
+    conv (Char x) = CharL x
+    conv (String x) = StringL x
+    conv (Int x) = IntegerL x
+    conv (Frac x) = RationalL x
+    conv (PrimInt x) = IntPrimL x
+    conv (PrimWord x) = WordPrimL x
+    conv (PrimFloat x) = FloatPrimL x
+    conv (PrimDouble x) = DoublePrimL x
+
+instance Convert HS.QName TH.Name where
+    conv (UnQual x) = c x
+    conv (Qual m x) = c (Ident $ prettyPrint m ++ "." ++ prettyPrint x)
+    conv (Special (TupleCon Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS
+
+instance Convert HS.PatField TH.FieldPat where
+    conv = undefined
+
+instance Convert HS.QOp TH.Exp where
+    conv (QVarOp x) = c $ Var x
+    conv (QConOp x) = c $ Con x
+
+instance Convert HS.Alt TH.Match where
+    conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)
+
+instance Convert HS.Stmt TH.Stmt where
+    conv (Generator _ x y) = BindS (c x) (c y)
+    conv (LetStmt x) = LetS (c x)
+    conv (Qualifier x) = NoBindS (c x)
+
+instance Convert HS.QualStmt TH.Stmt where
+    conv (QualStmt x) = c x
+
+instance Convert HS.FieldUpdate TH.FieldExp where
+    conv (FieldUpdate x y) = (c x, c y)
+
+instance Convert HS.TyVarBind TH.Name where
+    conv (UnkindedVar x) = c x
+
+#if __GLASGOW_HASKELL__ >= 612
+instance Convert TH.TyVarBndr HS.TyVarBind where
+    conv (PlainTV x) = UnkindedVar $ c x
+    conv (KindedTV x y) = KindedVar (c x) $ c y
+
+#if __GLASGOW_HASKELL__ < 706
+instance Convert TH.Kind HS.Kind where
+    conv StarK = KindStar
+    conv (ArrowK x y) = KindFn (c x) $ c y
+#else
+instance Convert TH.Kind HS.Kind where
+    conv StarT = KindStar
+    conv (AppT (AppT ArrowT x) y) = KindFn (c x) (c y)
+#endif
+
+#if __GLASGOW_HASKELL__ < 709
+instance Convert TH.Pred HS.Asst where
+    conv (ClassP x y) = ClassA (UnQual $ c x) $ c y
+    conv (TH.EqualP x y) = HS.EqualP (c x) $ c y
+
+instance Convert HS.Asst TH.Pred where
+    conv (ClassA x y) = ClassP (c x) $ c y
+    conv (HS.EqualP x y) = TH.EqualP (c x) $ c y
+#endif
+
+instance Convert HS.TyVarBind TH.TyVarBndr where
+    conv (UnkindedVar x) = PlainTV $ c x
+    conv (KindedVar x y) = KindedTV (c x) $ c y
+
+#if __GLASGOW_HASKELL__ < 706
+instance Convert HS.Kind TH.Kind where
+    conv KindStar = StarK
+    conv (KindFn x y) = ArrowK (c x) $ c y
+#else
+instance Convert HS.Kind TH.Kind where
+    conv KindStar = StarT
+    conv (KindFn x y) = AppT (AppT ArrowT (c x)) (c y)
+#endif
+#endif
diff --git a/src/Language/Haskell/TH/All.hs b/src/Language/Haskell/TH/All.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/TH/All.hs
@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -w #-}
+
+module Language.Haskell.TH.All (
+    module Language.Haskell.TH.All,
+    module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,
+    module Language.Haskell.TH.Helper,
+    module Language.Haskell.TH.Data,   module Language.Haskell.TH.ExpandSynonym,
+    ) where
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Peephole
+import Language.Haskell.TH.Helper
+import Language.Haskell.TH.ExpandSynonym
+import Language.Haskell.TH.Data
+
+import Control.Monad
+
+
+
+-- | The type of ways to derive classes.
+--   Should not really be in this module!
+data Derivation = Derivation {
+      derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper
+      derivationName    :: String              -- ^ The name of the derivation
+    }
+
+
+-- create a new derivation more abstractly
+derivation :: (DataDef -> [Dec]) -> String -> Derivation
+derivation f = Derivation (return . f)
+
+
+derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation
+derivationQ = Derivation
diff --git a/src/Language/Haskell/TH/Compat.hs b/src/Language/Haskell/TH/Compat.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/TH/Compat.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE CPP #-}
+
+-- | Compatibility definitions to paper over differences between 6.10 and 6.12.
+module Language.Haskell.TH.Compat where
+
+import Language.Haskell.TH
+
+
+#if __GLASGOW_HASKELL__ >= 612
+fromTyVar :: TyVarBndr -> Name
+fromTyVar (PlainTV v) = v
+fromTyVar (KindedTV v _) = v
+#else
+fromTyVar :: Name -> Name
+fromTyVar v = v
+#endif
+
+
+dataDefinitionTypeArgs :: Dec -> [Name]
+#if __GLASGOW_HASKELL__ >= 800
+dataDefinitionTypeArgs (DataD _cx name _ _ _ cxt) = map from_cxt cxt
+dataDefinitionTypeArgs (NewtypeD cx name _ _ _ cxt) = map from_cxt cxt
+#else    
+#if __GLASGOW_HASKELL__ >= 612
+dataDefinitionTypeArgs (DataD _cx name _ _ args) = args
+dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args
+#else
+dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args
+dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args
+#endif
+#endif
+
+from_cxt :: Type -> Name
+from_cxt (ConT name) = name
+
+#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 709
+typeToPred :: Type -> Pred
+typeToPred (ConT v) = ClassP v []
+typeToPred (AppT x y) = ClassP v (t++[y])
+    where ClassP v t = typeToPred x
+#else
+typeToPred :: Type -> Type
+typeToPred x = x
+#endif
diff --git a/src/Language/Haskell/TH/Data.hs b/src/Language/Haskell/TH/Data.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/TH/Data.hs
@@ -0,0 +1,142 @@
+
+-- | The core module of the Data.Derive system.  This module contains
+-- the data types used for communication between the extractors and
+-- the derivors.
+
+{-# language CPP #-}
+
+module Language.Haskell.TH.Data where
+
+import Data.Char
+import Data.Generics
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Compat
+
+
+-- must be one of DataD or NewtypeD
+type DataDef = Dec
+
+type CtorDef = Con
+
+
+dataName :: DataDef -> String
+#if __GLASGOW_HASKELL__ >= 800
+dataName (DataD    _ name _ _ _ _) = unqualifiedName name
+dataName (NewtypeD _ name _ _ _ _) = unqualifiedName name
+#else
+dataName (DataD    _ name _ _ _) = unqualifiedName name
+dataName (NewtypeD _ name _ _ _) = unqualifiedName name
+#endif
+
+qualifiedDataName :: DataDef -> Name
+#if __GLASGOW_HASKELL__ >= 800
+qualifiedDataName (DataD    _ name _ _ _ _) = name
+qualifiedDataName (NewtypeD _ name _ _ _ _) = name
+#else
+qualifiedDataName (DataD    _ name _ _ _) = name
+qualifiedDataName (NewtypeD _ name _ _ _) = name
+#endif
+
+dataArity :: DataDef -> Int
+#if __GLASGOW_HASKELL__ >= 800
+dataArity (DataD    _ _ xs _ _ _) = length xs
+dataArity (NewtypeD _ _ xs _ _ _) = length xs
+#else
+dataArity (DataD    _ _ xs _ _) = length xs
+dataArity (NewtypeD _ _ xs _ _) = length xs
+#endif
+
+dataArgs :: DataDef -> [Name]
+dataArgs = dataDefinitionTypeArgs
+
+
+dataCtors :: DataDef -> [CtorDef]
+#if __GLASGOW_HASKELL__ >= 800
+dataCtors (DataD    _ _ _ _ xs _) = xs
+dataCtors (NewtypeD _ _ _ _ x  _) = [x]
+#else
+dataCtors (DataD    _ _ _ xs _) = xs
+dataCtors (NewtypeD _ _ _ x  _) = [x]
+#endif
+
+
+ctorName :: CtorDef -> String
+ctorName (NormalC name _ ) = unqualifiedName name
+ctorName (RecC name _    ) = unqualifiedName name
+ctorName (InfixC _ name _) = unqualifiedName name
+ctorName (ForallC _ _ c  ) = ctorName c
+
+qualifiedCtorName :: CtorDef -> Name
+qualifiedCtorName (NormalC name _ ) = name
+qualifiedCtorName (RecC name _    ) = name
+qualifiedCtorName (InfixC _ name _) = name
+qualifiedCtorName (ForallC _ _ c  ) = qualifiedCtorName c
+
+
+ctorArity :: CtorDef -> Int
+ctorArity (NormalC _ xs ) = length xs
+ctorArity (RecC _ xs    ) = length xs
+ctorArity (InfixC _ _ _ ) = 2
+ctorArity (ForallC _ _ c) = ctorArity c
+
+
+ctorStrictTypes :: CtorDef -> [StrictType]
+ctorStrictTypes (NormalC _ xs ) = xs
+ctorStrictTypes (RecC _ xs    ) = [(b,c) | (a,b,c) <- xs]
+ctorStrictTypes (InfixC x _ y ) = [x,y]
+ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c
+
+
+ctorTypes :: CtorDef -> [Type]
+ctorTypes = map snd . ctorStrictTypes
+
+
+ctorFields :: CtorDef -> [String]
+ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType]
+ctorFields _ = []
+
+
+-- normalisation
+
+-- make sure you deal with "GHC.Base.."
+dropModule :: String -> String
+dropModule xs = case reverse xs of
+                    ('.':xs) -> takeWhile (== '.') xs
+                    xs -> reverse $ takeWhile (/= '.') xs
+
+-- i_123432 -> i
+dropNumber :: String -> String
+dropNumber xs = if all isDigit a then reverse (tail b) else xs
+    where (a,b) = break (== '_') $ reverse xs
+
+
+normData :: DataDef -> DataDef
+normData = everywhere (mkT normType)
+    where
+        normType :: Type -> Type
+        normType (ConT x) | show x == "[]" = ListT
+        normType x = x
+
+unqualifiedName :: Name -> String
+unqualifiedName = dropModule . show
+
+
+-- convert AppT chains back to a proper list
+typeApp :: Type -> (Type, [Type])
+typeApp (AppT l r) = (a, b++[r])
+    where (a,b) = typeApp l
+typeApp t = (t, [])
+
+
+
+eqConT :: String -> Type -> Bool
+eqConT name (ConT x) = name == show x
+eqConT _ _ = False
+
+isTupleT :: Type -> Bool
+isTupleT (TupleT _) = True
+isTupleT (ConT x) = head sx == '(' && last sx == ')' &&
+                    all (== ',') (take (length sx - 2) (tail sx))
+    where sx = nameBase x
+isTupleT _ = False
diff --git a/src/Language/Haskell/TH/ExpandSynonym.hs b/src/Language/Haskell/TH/ExpandSynonym.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/TH/ExpandSynonym.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE PatternGuards #-}
+
+-- | Expand type synonyms in data declarations.
+-- 
+--   This is needed for some type based derivations.
+module Language.Haskell.TH.ExpandSynonym (expandData) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Compat
+import Language.Haskell.TH.Data
+import Data.Generics
+
+-- | Expand type synonyms in a data declaration
+expandData :: DataDef -> Q DataDef
+expandData = everywhereM (mkM expandType)
+
+expandType :: Type -> Q Type
+expandType t = expandType' t []
+
+-- Walk over a type, collecting applied arguments
+expandType' :: Type -> [Type] -> Q Type
+expandType'   (AppT t arg) args   = expandType' t (arg:args)
+expandType' t@(ConT name)  args   = do result <- expandSyn name args
+                                       case result of
+                                          Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args'
+                                          _               -> return $ foldl AppT t args
+expandType' t              args   = return $ foldl AppT t args
+
+-- Is the name a type synonym and are there enough arguments? if so, apply it
+expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type]))
+expandSyn name args = recover (return Nothing) $ do
+            info <- reify name
+            case info of
+                   TyConI (TySynD _ synArgs t) | length args >= length synArgs
+                        -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym
+                             where (argsInst,argsMore) = splitAt (length synArgs) args
+                   _    -> return Nothing
+      -- `recover` return Nothing
+
+-- Substitute names for types in a type
+substitute :: [Name] -> [Type] -> Type -> Type
+substitute ns ts = subst (zip ns ts)
+  where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)
+        subst s (VarT n)
+           | Just t' <- lookup n s = t'
+        subst s (AppT a b)         = AppT (subst s a) (subst s b)
+        subst _ t                  = t
diff --git a/src/Language/Haskell/TH/Helper.hs b/src/Language/Haskell/TH/Helper.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/TH/Helper.hs
@@ -0,0 +1,248 @@
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+
+
+-- | These small short-named functions are intended to make the
+--   construction of abstranct syntax trees less tedious.
+module Language.Haskell.TH.Helper where
+
+import Data.Char
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Data
+import Language.Haskell.TH.Compat
+
+
+
+-- * Special folds for the guessing
+
+
+applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp
+applyWith  join xs = foldl  AppE join                      xs
+foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs
+foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs
+
+
+
+-- * Syntax elements
+--
+
+-- | A simple clause, without where or guards.
+sclause :: [Pat] -> Exp -> Clause
+sclause pats body = Clause pats (NormalB body) []
+
+-- | A default clause with N arguments.
+defclause :: Int -> Exp -> Clause
+defclause num = sclause (replicate num WildP)
+
+-- | A simple Val clause
+sval :: Pat -> Exp -> Dec
+sval pat body = ValD pat (NormalB body) []
+
+
+case' :: Exp -> [(Pat, Exp)] -> Exp
+case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ]
+
+(->:) :: String -> Exp -> Exp
+(->:) nm bdy = LamE [vr nm] bdy
+
+-- | We provide 3 standard instance constructors
+--   instance_default requires C for each free type variable
+--   instance_none requires no context
+--   instance_context requires a given context
+instance_none :: String -> DataDef -> [Dec] -> Dec
+instance_none = instance_context []
+
+instance_default :: String -> DataDef -> [Dec] -> Dec
+instance_default n = instance_context [n] n
+
+instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec
+instance_context req cls dat defs = InstanceD ctx hed defs
+    where
+        vrs = vars 't' (dataArity dat)
+        hed = l1 cls (lK (dataName dat) vrs)
+        ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]
+
+
+-- | Build an instance of a class for a data type, using the heuristic
+-- that the type is itself required on all type arguments.
+simple_instance :: String -> DataDef -> [Dec] -> [Dec]
+simple_instance cls dat defs = [instance_default cls dat defs]
+
+-- | Build an instance of a class for a data type, using the class at the given types
+generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec]
+generic_instance cls dat ctxTypes defs = [InstanceD ctx hed defs]
+    where
+        vrs = vars 't' (dataArity dat)
+        hed = l1 cls (lK (dataName dat) vrs)
+        ctx = map (typeToPred . l1 cls) ctxTypes
+
+-- | Build a type signature declaration with a string name
+sigN :: String -> Type -> Dec
+sigN nam ty = SigD (mkName nam) ty
+
+-- | Build a fundecl with a string name
+funN :: String -> [Clause] -> Dec
+funN nam claus = FunD (mkName nam) claus
+
+-- * Pattern vs Value abstraction
+
+class Eq nm => NameLike nm where
+  toName :: nm -> Name
+instance NameLike Name   where toName = id
+instance NameLike String where toName = mkName
+
+-- | The class used to overload lifting operations.  To reduce code
+-- duplication, we overload the wrapped constructors (and everything
+-- else, but that's irrelevant) to work in patterns, expressions, and
+-- types.
+class Valcon a where
+      -- | Build an application node, with a name for a head and a
+      -- provided list of arguments.
+      lK :: NameLike nm => nm -> [a] -> a
+      -- | Reference a named variable.
+      vr :: NameLike nm => nm -> a
+      -- | Lift a TH 'Lit'
+      raw_lit :: Lit -> a
+      -- | Tupling
+      tup :: [a] -> a
+      -- | Listing
+      lst :: [a] -> a
+instance Valcon Exp where
+      lK nm ys = let name = toName nm in case (nameBase name, ys) of
+        ("[]", []) -> ConE name
+        ("[]", xs) -> lst xs
+        ((x:_), args)  | isUpper x || x == ':' -> foldl AppE (ConE name) args
+        ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b)
+         where isOper x = not (isAlpha x || x == '_')
+        (nm,     args) -> foldl AppE (VarE name) args
+
+      vr = VarE . toName
+      raw_lit = LitE
+      tup = TupE
+      lst = ListE
+instance Valcon Pat where
+      lK = ConP . toName
+      vr = VarP . toName
+      raw_lit = LitP
+      tup = TupP
+      lst = ListP
+instance Valcon Type where
+      lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))
+        where bNm = nameBase (toName nm)
+      vr = VarT . toName
+      raw_lit = error "raw_lit @ Type"
+
+      -- XXX work around bug in GHC < 6.10
+      -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)
+      tup [t] = t
+      tup ts  = foldl AppT (TupleT (length ts)) ts
+
+      lst = error "lst @ Type"
+
+-- | Build an application node without a given head
+app :: Exp -> [Exp] -> Exp
+app root args = foldl AppE root args
+
+
+-- | This class is used to overload literal construction based on the
+-- type of the literal.
+class LitC a where
+      lit :: Valcon p => a -> p
+instance LitC Integer where
+      lit = raw_lit . IntegerL
+instance LitC Char where
+      lit = raw_lit . CharL
+instance LitC a => LitC [a] where
+      lit = lst . map lit
+instance (LitC a, LitC b) => LitC (a,b) where
+      lit (x,y) = tup [lit x, lit y]
+instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where
+      lit (x,y,z) = tup [lit x, lit y, lit z]
+instance LitC () where
+      lit () = tup []
+
+
+-- * Constructor abstraction
+
+dataVars :: DataDef -> [Type]
+dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..]
+
+-- | Common pattern: list of a familiy of variables
+vars :: Valcon a => Char -> Int -> [a]
+vars c n = map (vrn c) [1 .. n]
+
+-- | Variable based on a letter + number
+vrn :: Valcon a => Char -> Int -> a
+vrn c n = vr (c : show n)
+
+-- | Make a list of variables, one for each argument to a constructor
+ctv :: Valcon a => CtorDef -> Char -> [a]
+ctv ctor c = vars c (ctorArity ctor)
+
+-- | Make a simple pattern to bind a constructor
+ctp :: Valcon a => CtorDef -> Char -> a
+ctp ctor c = lK (ctorName ctor) (ctv ctor c)
+
+-- | Reference the constructor itself
+ctc :: Valcon a => CtorDef -> a
+ctc = l0 . ctorName
+
+
+-- * Lift a constructor over a fixed number of arguments.
+
+l0 :: (NameLike nm, Valcon a) => nm -> a
+l1 :: (NameLike nm, Valcon a) => nm -> a -> a
+l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a
+l0 s     = lK s []
+l1 s a   = lK s [a]
+l2 s a b = lK s [a,b]
+
+-- * Pre-lifted versions of common operations
+true, false, nil :: Valcon a => a
+hNil', hZero' :: Type
+true = l0 "True"
+false = l0 "False"
+nil = l0 "[]"
+unit = lit ()
+hNil' = l0 "HNil"
+hZero' = l0 "HZero"
+id' = l0 "id"
+
+cons :: Valcon a => a -> a -> a
+cons = l2 ":"
+
+box :: Valcon a => a -> a
+return', const' :: Exp -> Exp
+hSucc' :: Type -> Type
+box x = cons x nil
+return' = l1 "return"
+const' = l1 "const"
+hSucc' = l1 "HSucc"
+
+(==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp
+hCons' :: Type -> Type -> Type
+(==:) = l2 "=="
+(&&:) = l2 "&&"
+(++:) = l2 "++"
+(>>=:) = l2 ">>="
+(>>:) = l2 ">>"
+(.:) = l2 "."
+(>:) = l2 ">"
+ap' = l2 "ap"
+hCons' = l2 "HCons"
+
+-- | Build a chain of expressions, with an appropriate terminal
+--   sequence__ does not require a unit at the end (all others are optimised automatically)
+(&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp
+(&&::)  = foldr (&&:) true
+(++::) = foldr (++:) nil
+(>>::) = foldr (>>:) (return' unit)
+(.::) = foldr (.:) id'
+
+sequence__ [] = return' unit
+sequence__ xs = foldr1 (>>:) xs
+
+
+-- | K-way liftM
+liftmk :: Exp -> [Exp] -> Exp
+liftmk hd args = foldl ap' (return' hd) args
diff --git a/src/Language/Haskell/TH/Peephole.hs b/src/Language/Haskell/TH/Peephole.hs
new file mode 100644
--- /dev/null
+++ b/src/Language/Haskell/TH/Peephole.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where
+
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Helper
+import Data.Generics
+import Data.Maybe
+import Data.List
+import Debug.Trace
+
+traceMode = False
+
+
+peephole :: Data a => a -> a
+peephole = everywhere (mkT peep) . everywhere (mkT peepPat)
+
+
+
+-- find a given string, and replace it with a particular expression
+-- must succeed, so crashes readily (deliberately!)
+replaceVars :: [(Name,Exp)] -> Exp -> Exp
+replaceVars rep orig = fExp orig
+    where
+        fExp x = case x of
+            VarE y -> fromMaybe x $ lookup y rep
+            ConE _ -> x
+            LitE _ -> x
+            AppE x y -> AppE (fExp x) (fExp y)
+            CaseE x y -> CaseE (fExp x) (map fMatch y)
+            TupE xs -> TupE (map fExp xs)
+            ListE xs -> ListE (map fExp xs)
+            LamE x y -> LamE x (fPat x y)
+            _ | null $ map fst rep `intersect` getNames x -> x
+            _ -> error $ "replaceVar: " ++ show x
+
+        getNames x = everything (++) ([] `mkQ` f) x
+            where
+                f :: Name -> [Name]
+                f x = [x]
+
+        fMatch o@(Match pat (NormalB bod) []) =
+            Match pat (NormalB $ fPat [pat] bod) []
+
+        -- given these pattern have come into scope
+        -- continue matching on the rest
+        fPat :: [Pat] -> Exp -> Exp
+        fPat pat = replaceVars (filter ((`notElem` used) . fst) rep)
+            where used = concatMap usedPats pat
+
+        usedPats x = everything (++) ([] `mkQ` f) x
+            where
+                f (VarP x) = [x]
+                f _ = []
+
+
+replaceVar :: Name -> Exp -> Exp -> Exp
+replaceVar name with = replaceVars [(name,with)]
+
+
+
+-- based on the rewrite combinator in Play
+peep :: Exp -> Exp
+peep (ListE xs)
+    | not (null xs) && all (isJust . fromLitChar) xs =
+      peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs
+    where
+        fromLitChar (LitE (CharL x)) = Just x
+        fromLitChar _ = Nothing
+
+peep (AppE x y)
+    | x ~= "id" = y
+
+peep (AppE (AppE op x) y)
+    | Just res <- peepBin op x y = res
+
+peep (InfixE (Just x) op (Just y))
+    | Just res <- peepBin op x y = res
+
+peep (LamE [] x) = x
+
+peep (LamE [VarP x] (VarE y))
+    | x == y = l0 "id"
+
+peep (DoE [NoBindS x]) = x
+
+peep x@(ConE _)
+    | x ~= "[]" = ListE []
+
+peep (AppE (AppE cons x) nil)
+    | cons ~= ":" && nil ~= "[]" = ListE [x]
+
+peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e])
+    | ret ~= "return" = peep $ replaceVar p (LitE val) e
+
+peep (LamE [TupP [VarP x, VarP y]] (VarE z))
+    | x == z = l0 "fst"
+    | y == z = l0 "snd"
+
+peep (AppE (LamE (VarP x:xs) y) z)
+    | simple z
+    = peep $ LamE xs (replaceVar x z y)
+
+peep (AppE (AppE bind (AppE ret x)) y)
+    | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x
+
+peep (InfixE (Just (AppE ret x)) bind (Just y))
+    | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x
+
+peep (InfixE (Just (AppE pure x)) ap y)
+    | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y
+
+peep (InfixE (Just x) fmap (Just (AppE pure y)))
+    | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)
+
+peep (AppE append (ListE [x]))
+    | append ~= "++" = peep $ AppE (l0 ":") x
+
+peep (InfixE (Just (ListE [x])) append y)
+    | append ~= "++" = peep $ InfixE (Just x) (l0 ":") y
+
+peep (InfixE (Just x) cons (Just (ListE xs)))
+    | cons ~= ":" = peep $ ListE (x:xs)
+
+peep (AppE (AppE (AppE comp f) g) x)
+    | comp ~= "."  = peep $ AppE f (peep $ AppE g x)
+peep (AppE (InfixE (Just f) comp (Just g)) x)
+    | comp ~= "."  = peep $ AppE f (peep $ AppE g x)
+
+peep (AppE (AppE (AppE flip f) x) y)
+    | flip ~= "flip"  = peep $ AppE (AppE f y) x
+
+peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)
+peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)
+
+peep (AppE f (LamE x (ListE [y])))
+    | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y)
+
+peep (AppE f (ListE xs))
+    | f ~= "head" && not (null xs) = head xs
+    | f ~= "reverse" = ListE $ reverse xs
+
+peep (AppE f (TupE [x,y]))
+    | f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x
+
+peep (AppE (AppE sq o@(AppE rnf x)) (TupE []))
+    | sq ~= "seq" && rnf ~= "rnf" = o
+
+peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))
+    | x == y = z
+
+peep (AppE len (ListE xs))
+    | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs
+
+peep (TupE [x]) = x
+
+peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]
+
+peep (AppE (CaseE e [Match p (NormalB x) []]) y)
+       = CaseE e [Match p (NormalB $ peep $ AppE x y) []]
+
+-- allow easy flip to tracing mode
+peep x | traceMode = trace (show x) x
+peep x = x
+
+
+peepPat :: Pat -> Pat
+peepPat (ListP xs)
+    | all (\x -> case x of LitP (CharL _) -> True
+                           _ -> False) xs =
+      LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs
+
+peepPat x = x
+
+peepBin :: Exp -> Exp -> Exp -> Maybe Exp
+peepBin op x y
+    | op ~= "." && x ~= "id" = Just y
+    | op ~= "." && y ~= "id" = Just x
+    | op ~= "&&" && y ~= "True" = Just x
+    | op ~= "const" = Just x
+    | op ~= "map" && x ~= "id" = Just y
+    | op ~= "++" && x ~= "[]" = Just y
+    | op ~= "++" && y ~= "[]" = Just x
+    | op ~= "." && y ~= "id" = Just x
+    | op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id"
+    | op ~= "$" = Just $ peep $ AppE x y
+
+peepBin op (LitE (StringL x)) (LitE (StringL y))
+    | op ~= "++" = Just $ LitE $ StringL (x++y)
+
+peepBin _ _ _ = Nothing
+
+
+(VarE f) ~= x = show f == x
+(ConE f) ~= x = show f == x
+(ListE []) ~= "[]" = True
+_ ~= _ = False
+
+
+simple (VarE _) = True
+simple (LitE _) = True
+simple _ = False