derive 2.5.23 → 2.5.24

raw patch · 132 files changed

+5593/−5941 lines, 132 filesdep +derivePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: derive

API changes (from Hackage documentation)

Files

• CHANGES.txt +4/−0
• Data/Derive/All.hs +0/−45
• Data/Derive/Arbitrary.hs +0/−83
• Data/Derive/ArbitraryOld.hs +0/−74
• Data/Derive/Arities.hs +0/−44
• Data/Derive/Binary.hs +0/−134
• Data/Derive/BinaryDefer.hs +0/−63
• Data/Derive/Bounded.hs +0/−42
• Data/Derive/Class/Arities.hs +0/−5
• Data/Derive/Class/Default.hs +0/−5
• Data/Derive/DSL/Apply.hs +0/−74
• Data/Derive/DSL/DSL.hs +0/−112
• Data/Derive/DSL/Derive.hs +0/−142
• Data/Derive/DSL/HSE.hs +0/−112
• Data/Derive/DSL/SYB.hs +0/−110
• Data/Derive/Data.hs +0/−154
• Data/Derive/DataAbstract.hs +0/−59
• Data/Derive/Default.hs +0/−32
• Data/Derive/Enum.hs +0/−52
• Data/Derive/EnumCyclic.hs +0/−105
• Data/Derive/Eq.hs +0/−60
• Data/Derive/Fold.hs +0/−67
• Data/Derive/Foldable.hs +0/−55
• Data/Derive/From.hs +0/−65
• Data/Derive/Functor.hs +0/−62
• Data/Derive/Has.hs +0/−40
• Data/Derive/Instance/Arities.hs +0/−14
• Data/Derive/Internal/Derivation.hs +0/−49
• Data/Derive/Internal/Instance.hs +0/−34
• Data/Derive/Internal/Traversal.hs +0/−211
• Data/Derive/Is.hs +0/−33
• Data/Derive/JSON.hs +0/−165
• Data/Derive/LazySet.hs +0/−38
• Data/Derive/Lens.hs +0/−41
• Data/Derive/Monoid.hs +0/−69
• Data/Derive/NFData.hs +0/−35
• Data/Derive/Ord.hs +0/−95
• Data/Derive/Read.hs +0/−199
• Data/Derive/Ref.hs +0/−42
• Data/Derive/Serial.hs +0/−65
• Data/Derive/Serialize.hs +0/−134
• Data/Derive/Set.hs +0/−40
• Data/Derive/Show.hs +0/−90
• Data/Derive/Traversable.hs +0/−56
• Data/Derive/Typeable.hs +0/−96
• Data/Derive/UniplateDirect.hs +0/−220
• Data/Derive/UniplateTypeable.hs +0/−73
• Data/Derive/Update.hs +0/−47
• Data/DeriveDSL.hs +0/−21
• Data/DeriveMain.hs +0/−19
• Data/DeriveTH.hs +0/−44
• Derive/Derivation.hs +0/−100
• Derive/Flags.hs +0/−65
• Derive/Generate.hs +0/−115
• Derive/Main.hs +0/−63
• Derive/Test.hs +0/−100
• Derive/Utils.hs +0/−86
• LICENSE +1/−1
• Language/Haskell.hs +0/−300
• Language/Haskell/Convert.hs +0/−279
• Language/Haskell/TH/All.hs +0/−35
• Language/Haskell/TH/Compat.hs +0/−36
• Language/Haskell/TH/Data.hs +0/−119
• Language/Haskell/TH/ExpandSynonym.hs +0/−47
• Language/Haskell/TH/FixedPpr.hs +0/−414
• Language/Haskell/TH/Helper.hs +0/−248
• Language/Haskell/TH/Peephole.hs +0/−202
• derive.cabal +6/−5
• src/Data/Derive/All.hs +45/−0
• src/Data/Derive/Arbitrary.hs +83/−0
• src/Data/Derive/ArbitraryOld.hs +74/−0
• src/Data/Derive/Arities.hs +44/−0
• src/Data/Derive/Binary.hs +134/−0
• src/Data/Derive/BinaryDefer.hs +63/−0
• src/Data/Derive/Bounded.hs +42/−0
• src/Data/Derive/Class/Arities.hs +5/−0
• src/Data/Derive/Class/Default.hs +5/−0
• src/Data/Derive/DSL/Apply.hs +74/−0
• src/Data/Derive/DSL/DSL.hs +112/−0
• src/Data/Derive/DSL/Derive.hs +142/−0
• src/Data/Derive/DSL/HSE.hs +112/−0
• src/Data/Derive/DSL/SYB.hs +110/−0
• src/Data/Derive/Data.hs +154/−0
• src/Data/Derive/DataAbstract.hs +59/−0
• src/Data/Derive/Default.hs +32/−0
• src/Data/Derive/Enum.hs +52/−0
• src/Data/Derive/EnumCyclic.hs +105/−0
• src/Data/Derive/Eq.hs +60/−0
• src/Data/Derive/Fold.hs +67/−0
• src/Data/Derive/Foldable.hs +55/−0
• src/Data/Derive/From.hs +65/−0
• src/Data/Derive/Functor.hs +62/−0
• src/Data/Derive/Has.hs +40/−0
• src/Data/Derive/Instance/Arities.hs +14/−0
• src/Data/Derive/Internal/Derivation.hs +49/−0
• src/Data/Derive/Internal/Instance.hs +34/−0
• src/Data/Derive/Internal/Traversal.hs +211/−0
• src/Data/Derive/Is.hs +33/−0
• src/Data/Derive/JSON.hs +165/−0
• src/Data/Derive/LazySet.hs +38/−0
• src/Data/Derive/Lens.hs +41/−0
• src/Data/Derive/Monoid.hs +69/−0
• src/Data/Derive/NFData.hs +35/−0
• src/Data/Derive/Ord.hs +95/−0
• src/Data/Derive/Read.hs +199/−0
• src/Data/Derive/Ref.hs +42/−0
• src/Data/Derive/Serial.hs +65/−0
• src/Data/Derive/Serialize.hs +134/−0
• src/Data/Derive/Set.hs +40/−0
• src/Data/Derive/Show.hs +90/−0
• src/Data/Derive/Traversable.hs +56/−0
• src/Data/Derive/Typeable.hs +96/−0
• src/Data/Derive/UniplateDirect.hs +220/−0
• src/Data/Derive/UniplateTypeable.hs +73/−0
• src/Data/Derive/Update.hs +47/−0
• src/Data/DeriveDSL.hs +21/−0
• src/Data/DeriveMain.hs +19/−0
• src/Data/DeriveTH.hs +44/−0
• src/Derive/Derivation.hs +100/−0
• src/Derive/Flags.hs +65/−0
• src/Derive/Generate.hs +115/−0
• src/Derive/Main.hs +63/−0
• src/Derive/Test.hs +100/−0
• src/Derive/Utils.hs +86/−0
• src/Language/Haskell.hs +300/−0
• src/Language/Haskell/Convert.hs +310/−0
• src/Language/Haskell/TH/All.hs +34/−0
• src/Language/Haskell/TH/Compat.hs +44/−0
• src/Language/Haskell/TH/Data.hs +142/−0
• src/Language/Haskell/TH/ExpandSynonym.hs +47/−0
• src/Language/Haskell/TH/Helper.hs +248/−0
• src/Language/Haskell/TH/Peephole.hs +202/−0

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

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

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

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

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

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

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

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

@@ -1,5 +0,0 @@--module Data.Derive.Class.Arities where--class Arities a where-    arities :: a -> [Int]

@@ -1,5 +0,0 @@--module Data.Derive.Class.Default where--class Default a where-    def :: a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -0,0 +1,5 @@++module Data.Derive.Class.Arities where++class Arities a where+    arities :: a -> [Int]

@@ -0,0 +1,5 @@++module Data.Derive.Class.Default where++class Default a where+    def :: a

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

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

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

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

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

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

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

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