derive 2.5.26 → 2.6

raw patch · 55 files changed

+1557/−2089 lines, 55 filesdep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

• CHANGES.txt +4/−0
• LICENSE +1/−1
• README.md +0/−10
• derive.cabal +7/−15
• src/Data/Derive/All.hs +1/−11
• src/Data/Derive/Arbitrary.hs +60/−37
• src/Data/Derive/ArbitraryOld.hs +60/−45
• src/Data/Derive/Arities.hs +13/−9
• src/Data/Derive/Binary.hs +122/−75
• src/Data/Derive/BinaryDefer.hs +52/−32
• src/Data/Derive/Bounded.hs +35/−21
• src/Data/Derive/DSL/Apply.hs +13/−11
• src/Data/Derive/DSL/Derive.hs +30/−15
• src/Data/Derive/DSL/HSE.hs +3/−3
• src/Data/Derive/DSL/SYB.hs +18/−18
• src/Data/Derive/Data.hs +0/−154
• src/Data/Derive/DataAbstract.hs +45/−25
• src/Data/Derive/Default.hs +18/−12
• src/Data/Derive/Enum.hs +0/−52
• src/Data/Derive/EnumCyclic.hs +117/−70
• src/Data/Derive/Eq.hs +0/−60
• src/Data/Derive/Fold.hs +7/−7
• src/Data/Derive/Foldable.hs +0/−55
• src/Data/Derive/From.hs +11/−11
• src/Data/Derive/Functor.hs +0/−62
• src/Data/Derive/Has.hs +5/−5
• src/Data/Derive/Internal/Derivation.hs +8/−11
• src/Data/Derive/Internal/Traversal.hs +55/−47
• src/Data/Derive/Is.hs +5/−5
• src/Data/Derive/JSON.hs +78/−65
• src/Data/Derive/LazySet.hs +6/−5
• src/Data/Derive/Lens.hs +3/−3
• src/Data/Derive/Monoid.hs +65/−41
• src/Data/Derive/NFData.hs +21/−14
• src/Data/Derive/Ord.hs +0/−95
• src/Data/Derive/Read.hs +0/−199
• src/Data/Derive/Ref.hs +7/−7
• src/Data/Derive/Serial.hs +53/−34
• src/Data/Derive/Serialize.hs +122/−74
• src/Data/Derive/Set.hs +5/−4
• src/Data/Derive/Show.hs +0/−90
• src/Data/Derive/Traversable.hs +0/−56
• src/Data/Derive/Typeable.hs +0/−96
• src/Data/Derive/UniplateDirect.hs +42/−29
• src/Data/Derive/UniplateTypeable.hs +63/−34
• src/Data/Derive/Update.hs +6/−6
• src/Data/DeriveDSL.hs +3/−3
• src/Data/DeriveTH.hs +1/−1
• src/Derive/Derivation.hs +17/−16
• src/Derive/Generate.hs +3/−3
• src/Derive/Main.hs +5/−4
• src/Derive/Test.hs +10/−10
• src/Derive/Utils.hs +8/−8
• src/Language/Haskell.hs +151/−136
• src/Language/Haskell/Convert.hs +198/−177

@@ -1,5 +1,9 @@ Changelog for Derive +2.6+    Remove lots of derivations that didn't seem useful (Eq, Show etc)+    Change to use annotated Haskell syntax trees+    Require haskell-src-exts-1.18 2.5.26     #17, fix incomplete pattern matches for certain types of data 2.5.25

@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2016.+Copyright Neil Mitchell 2006-2017. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -35,16 +35,11 @@ * **[Binary](http://hackage.haskell.org/packages/archive/binary/latest/doc/html/Data-Binary.html#t%3ABinary)** - from the library [binary](http://hackage.haskell.org/package/binary) * **[BinaryDefer](http://hackage.haskell.org/packages/archive/binarydefer/latest/doc/html/Data-Binary-Defer.html#t%3ABinaryDefer)** - from the library [binarydefer](http://hackage.haskell.org/package/binarydefer) * **[Bounded](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ABounded)** - from the library [base](http://hackage.haskell.org/package/base)-* **[Data](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3AData)** - from the library [base](http://hackage.haskell.org/package/base) * **[DataAbstract](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3ADataAbstract)** - from the library [base](http://hackage.haskell.org/package/base) * **[Default](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Default.html#t%3ADefault)** - from the library [derive](http://hackage.haskell.org/package/derive)-* **[Enum](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base) * **[EnumCyclic](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)-* **[Eq](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEq)** - from the library [base](http://hackage.haskell.org/package/base) * **[Fold](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Fold.html)**-* **[Foldable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Foldable.html#t%3AFoldable)** - from the library [base](http://hackage.haskell.org/package/base) * **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)**-* **[Functor](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AFunctor)** - from the library [base](http://hackage.haskell.org/package/base) * **[Has](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html)** * **[Is](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html)** * **[JSON](http://hackage.haskell.org/packages/archive/json/latest/doc/html/Text-JSON.html#t%3AJSON)** - from the library [json](http://hackage.haskell.org/package/json)@@ -52,15 +47,10 @@ * **[Lens](http://hackage.haskell.org/packages/archive/data/lens/doc/html/Data-Lens-Common.html#t%3ALens)** - from the library [data-lens](http://hackage.haskell.org/package/data-lens) * **[Monoid](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid)** - from the library [base](http://hackage.haskell.org/package/base) * **[NFData](http://hackage.haskell.org/packages/archive/deepseq/latest/doc/html/Control-DeepSeq.html#t%3ANFData)** - from the library [deepseq](http://hackage.haskell.org/package/deepseq)-* **[Ord](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AOrd)** - from the library [base](http://hackage.haskell.org/package/base)-* **[Read](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ARead)** - from the library [base](http://hackage.haskell.org/package/base) * **[Ref](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html)** * **[Serial](http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial)** - from the library [smallcheck](http://hackage.haskell.org/package/smallcheck) * **[Serialize](http://hackage.haskell.org/packages/archive/cereal/latest/doc/html/Data-Serialize.html#t%3ASerialize)** - from the library [cereal](http://hackage.haskell.org/package/cereal) * **[Set](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Set.html)**-* **[Show](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AShow)** - from the library [base](http://hackage.haskell.org/package/base)-* **[Traversable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Traversable.html#t%3ATraversable)** - from the library [base](http://hackage.haskell.org/package/base)-* **[Typeable](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Typeable.html#t%3ATypeable)** - from the library [base](http://hackage.haskell.org/package/base) * **[UniplateDirect](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Direct.html#t%3AUniplateDirect)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate) * **[UniplateTypeable](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Typeable.html#t%3AUniplateTypeable)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate) * **[Update](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Update.html)**

@@ -1,9 +1,9 @@-cabal-version:  >= 1.8+cabal-version:  >= 1.18 build-type:     Default name:           derive-version:        2.5.26+version:        2.6 build-type:     Simple-copyright:      Neil Mitchell 2006-2016+copyright:      Neil Mitchell 2006-2017 author:         Neil Mitchell <ndmitchell@gmail.com> maintainer:     Neil Mitchell <ndmitchell@gmail.com> homepage:       https://github.com/ndmitchell/derive#readme@@ -20,23 +20,25 @@ extra-doc-files:     README.md     CHANGES.txt-tested-with:        GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+tested-with:        GHC==8.0.2, GHC==7.10.3  source-repository head     type:     git     location: https://github.com/ndmitchell/derive.git  executable derive+    default-language: Haskell2010     build-depends: base==4.* , derive     main-is: Main.hs  library+    default-language: Haskell2010     hs-source-dirs: src     build-depends:         base == 4.*,         filepath, syb, template-haskell, containers, pretty,         directory, process, bytestring,-        haskell-src-exts >= 1.17 && < 1.18,+        haskell-src-exts >= 1.18 && < 1.19,         transformers >= 0.2,         uniplate >= 1.5 && < 1.7 @@ -68,16 +70,11 @@         Data.Derive.Binary         Data.Derive.BinaryDefer         Data.Derive.Bounded-        Data.Derive.Data         Data.Derive.DataAbstract         Data.Derive.Default-        Data.Derive.Enum         Data.Derive.EnumCyclic-        Data.Derive.Eq         Data.Derive.Fold-        Data.Derive.Foldable         Data.Derive.From-        Data.Derive.Functor         Data.Derive.Has         Data.Derive.Is         Data.Derive.JSON@@ -85,15 +82,10 @@         Data.Derive.Lens         Data.Derive.Monoid         Data.Derive.NFData-        Data.Derive.Ord-        Data.Derive.Read         Data.Derive.Ref         Data.Derive.Serial         Data.Derive.Serialize         Data.Derive.Set-        Data.Derive.Show-        Data.Derive.Traversable-        Data.Derive.Typeable         Data.Derive.UniplateDirect         Data.Derive.UniplateTypeable         Data.Derive.Update

@@ -11,16 +11,11 @@ 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@@ -28,18 +23,13 @@ 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]+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeDataAbstract,makeDefault,makeEnumCyclic,makeFold,makeFrom,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeRef,makeSerial,makeSerialize,makeSet,makeUniplateDirect,makeUniplateTypeable,makeUpdate] -- GENERATED STOP

@@ -33,40 +33,63 @@  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+    List [Instance [] "Arbitrary" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs" (List+    [App "()" (List []),App "Do" (List [App "()" (List []),List [App+    "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),String "x"])]),App+    "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+    ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "choose"])])]),App "Tuple" (List [App "()" (+    List []),App "Boxed" (List []),List [App "ExpTypeSig" (List [App+    "()" (List []),App "Lit" (List [App "()" (List []),App "Int" (List+    [App "()" (List []),Int 0,ShowInt (Int 0)])]),App "TyCon" (List [+    App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "Int"])])])]),App+    "InfixApp" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "length"])])]),App "List" (List [App "()" (List []),MapCtor (App+    "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+    (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+    []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Symbol" (List [App "()" (List []),+    String "-"])])]),App "Lit" (List [App "()" (List []),App "Int" (+    List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]])])]),App+    "Qualifier" (List [App "()" (List []),App "Case" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "x"])])]),Concat (List [MapCtor (App "Alt" (List [App "()" (List [+    ]),App "PLit" (List [App "()" (List []),App "Signless" (List [App+    "()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,+    ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])+    ,App "Do" (List [App "()" (List []),Concat (List [MapField (App+    "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),Concat (List [+    String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "arbitrary"])])])])),List [App+    "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "return"])])]),App "Paren" (List [App "()" (List []),Application (+    Concat (List [List [App "Con" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+    []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+    )]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List+    [App "()" (List []),App "PWildCard" (List [App "()" (List [])]),+    App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+    "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "error"])])]),App "Lit" (List [App "()" (List []),App+    "String" (List [App "()" (List []),String+    "FATAL ERROR: Arbitrary instance, logic bug",String     "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "Nothing"-    (List [])])]])])])]])]),App "Nothing" (List [])])])])]+    (List [])])]])])])]])]),App "Nothing" (List [])])])]]))] -- GENERATED STOP  custom = customContext context@@ -74,10 +97,10 @@ -- 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+context :: FullDataDecl -> Context () -> Context ()+context (_,d) _ = CxTuple () $ 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 (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) 

@@ -15,9 +15,9 @@             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+    coarbitrary (First) = ()+    coarbitrary (Second x1 x2) = ()+    coarbitrary (Third x1) = ()  -} -- GENERATED START@@ -29,46 +29,61 @@ 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 [])]))])])]-    )]+    List [Instance ["Arbitrary"] "Arbitrary" (App "Just" (List [List [+    App "InsDecl" (List [App "()" (List []),App "PatBind" (List [App+    "()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (+    List [App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs"+    (List [App "()" (List []),App "Do" (List [App "()" (List []),List+    [App "Generator" (List [App "()" (List []),App "PVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String "x"])]+    ),App "App" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "choose"])])]),App "Tuple" (List [App+    "()" (List []),App "Boxed" (List []),List [App "Lit" (List [App+    "()" (List []),App "Int" (List [App "()" (List []),Int 0,ShowInt (+    Int 0)])]),App "InfixApp" (List [App "()" (List []),App "App" (+    List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "length"])])]),App "List" (List [App "()" (List []+    ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])+    ,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+    "()" (List []),String "-"])])]),App "Lit" (List [App "()" (List []+    ),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]+    ])])]),App "Qualifier" (List [App "()" (List []),App "Case" (List+    [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List+    []),App "PLit" (List [App "()" (List []),App "Signless" (List [App+    "()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,+    ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])+    ,App "Do" (List [App "()" (List []),Concat (List [MapField (App+    "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),Concat (List [+    String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "arbitrary"])])])])),List [App+    "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "return"])])]),App "Paren" (List [App "()" (List []),Application (+    Concat (List [List [App "Con" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+    []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+    )]))])])])]])])]),App "Nothing" (List [])]))])])]])]),App+    "Nothing" (List [])])]),App "InsDecl" (List [App "()" (List []),+    App "FunBind" (List [App "()" (List []),MapCtor (App "Match" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "coarbitrary"]),List [App "PParen" (List [App "()" (List []),App+    "PApp" (List [App "()" (List []),App "UnQual" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),CtorName])]),+    MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])+    ]))])])],App "UnGuardedRhs" (List [App "()" (List []),App "Con" (+    List [App "()" (List []),App "Special" (List [App "()" (List []),+    App "UnitCon" (List [App "()" (List [])])])])]),App "Nothing" (+    List [])]))])])]]))] -- GENERATED STOP

@@ -32,13 +32,17 @@ 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 [-    ])])]])])])]+    List [Instance [] "Arities" (App "Just" (List [List [App "InsDecl"+    (List [App "()" (List []),App "FunBind" (List [App "()" (List []),+    List [App "Match" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "arities"]),List [App "PWildCard" (List [App+    "()" (List [])])],App "UnGuardedRhs" (List [App "()" (List []),App+    "List" (List [App "()" (List []),MapCtor (Application (List [App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "const"])])]),App+    "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []+    ),CtorArity,ShowInt CtorArity])]),App "RecConstr" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),CtorName])]),List []])]))])]),App "Nothing" (+    List [])])]])])]]))] -- GENERATED STOP

@@ -56,79 +56,126 @@ 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-    [])])]])])])])])]+    List [Instance ["Binary"] "Binary" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+    (List []),List [App "Match" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "put"]),List [App "PVar" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App "Case" (+    List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List+    []),App "PApp" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),+    MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])+    ]))]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List+    [App "()" (List []),Concat (List [List [App "Qualifier" (List [App+    "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "putTag"])])]),App "Lit"+    (List [App "()" (List []),App "Int" (List [App "()" (List []),+    CtorIndex,ShowInt CtorIndex])])])])],MapField (App "Qualifier" (+    List [App "()" (List []),App "App" (List [App "()" (List []),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "put"])])]),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+    ,ShowInt FieldIndex])])])])])]))])])]),App "Nothing" (List [])]))]+    )]),App "Just" (List [App "BDecls" (List [App "()" (List []),List+    [App "PatBind" (List [App "()" (List []),App "PVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String+    "useTag"])]),App "UnGuardedRhs" (List [App "()" (List []),App+    "InfixApp" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "length"])])]),App "List" (List [App "()" (List []),MapCtor (App+    "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+    (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+    []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Symbol" (List [App "()" (List []),+    String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (+    List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App+    "Nothing" (List [])]),App "FunBind" (List [App "()" (List []),List+    [App "Match" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "putTag"]),List [App "PVar" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "x"])])],App+    "UnGuardedRhs" (List [App "()" (List []),Application (List [App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "when"])])]),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "useTag"])])]),+    App "Paren" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+    List [String "putWord",ShowInt (Int 8)])])])]),App "Var" (List [+    App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "x"])])])])])])]),App+    "Nothing" (List [])])]])]])])])]])]),App "InsDecl" (List [App "()"+    (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "get"])]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (+    List [App "()" (List []),List [App "Generator" (List [App "()" (+    List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "i"])]),App "Var" (List [App "()" (List+    []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "getTag"])])])]),App "Qualifier" (List [App+    "()" (List []),App "Case" (List [App "()" (List []),App "Var" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "i"])])]),Concat (+    List [MapCtor (App "Alt" (List [App "()" (List []),App "PLit" (+    List [App "()" (List []),App "Signless" (List [App "()" (List [])]+    ),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex]+    )]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List [+    App "()" (List []),Concat (List [MapField (App "Generator" (List [+    App "()" (List []),App "PVar" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),Concat (List [String "x",ShowInt+    FieldIndex])])]),App "Var" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "get"])])])])),List [App "Qualifier" (List [App "()" (List+    []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "return"])])]),App "Paren" (List [App+    "()" (List []),Application (Concat (List [List [App "Con" (List [+    App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),CtorName])])])],MapField (App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+    ,ShowInt FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [+    ])])),List [App "Alt" (List [App "()" (List []),App "PWildCard" (+    List [App "()" (List [])]),App "UnGuardedRhs" (List [App "()" (+    List []),App "App" (List [App "()" (List []),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "error"])])]),App "Lit" (List [+    App "()" (List []),App "String" (List [App "()" (List []),Concat (+    List [String "Corrupted binary data for ",DataName]),Concat (List+    [String "Corrupted binary data for ",DataName])])])])]),App+    "Nothing" (List [])])]])])])]])]),App "Just" (List [App "BDecls" (+    List [App "()" (List []),List [App "PatBind" (List [App "()" (List+    []),App "PVar" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "useTag"])]),App "UnGuardedRhs" (List [App+    "()" (List []),App "InfixApp" (List [App "()" (List []),App "App"+    (List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "length"])])]),App "List" (List [App "()" (List []+    ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])+    ,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+    "()" (List []),String ">"])])]),App "Lit" (List [App "()" (List []+    ),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]+    ),App "Nothing" (List [])]),App "PatBind" (List [App "()" (List []+    ),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (+    List []),App "If" (List [App "()" (List []),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "useTag"])])]),App "Var" (List [+    App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),Concat (List [String "getWord",+    ShowInt (Int 8)])])])]),App "App" (List [App "()" (List []),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "return"])])]),+    App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+    List []),Int 0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])+    ]])])])])]]))] -- GENERATED STOP

@@ -28,36 +28,56 @@ 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 [])])])])]+    List [Instance ["BinaryDefer"] "BinaryDefer" (App "Just" (List [+    List [App "InsDecl" (List [App "()" (List []),App "PatBind" (List+    [App "()" (List []),App "PVar" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "bothDefer"])]),App+    "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"+    (List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "defer"])])]),App "List" (List [App "()" (List []),MapCtor (App+    "Lambda" (List [App "()" (List []),List [App "PIrrPat" (List [App+    "()" (List []),App "PParen" (List [App "()" (List []),App "PAsPat"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "o"]),App "PParen" (List [App "()" (List []),App "PApp" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),CtorName])]),MapField (App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),Concat (List [String "x",ShowInt FieldIndex])])]))])])])])])],+    App "If" (List [App "()" (List []),App "App" (List [App "()" (List+    []),App "Var" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String "null"+    ])])]),App "List" (List [App "()" (List []),MapField (Application+    (List [App "Var" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String+    "const"])])]),App "Con" (List [App "()" (List []),App "Special" (+    List [App "()" (List []),App "UnitCon" (List [App "()" (List [])])+    ])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+    [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp" (List+    [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+    (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "unit"])])]),App+    "Paren" (List [App "()" (List []),Application (Concat (List [List+    [App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"+    (List []),App "Ident" (List [App "()" (List []),CtorName])])])],+    MapField (App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+    List [String "x",ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Symbol" (List [App "()" (List []),String "<<!"])])]),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "o"])])])]),Fold+    (App "InfixApp" (List [App "()" (List []),Tail,App "QVarOp" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Symbol" (List [App "()" (List []),String "<<"])])]),Head])) (+    Concat (List [Reverse (MapField (App "Var" (List [App "()" (List [+    ]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+    )),List [App "App" (List [App "()" (List []),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "unit"])])]),App "Con" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),CtorName])])])])]]))])]))])])]),App+    "Nothing" (List [])])])]]))] -- GENERATED STOP

@@ -18,25 +18,39 @@ 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 [])])])])]+    List [Instance ["Bounded"] "Bounded" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "minBound"])]),App "UnGuardedRhs" (List+    [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+    (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "head"])])]),App+    "List" (List [App "()" (List []),MapCtor (Application (Concat (+    List [List [App "Con" (List [App "()" (List []),App "UnQual" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+    ])])])],MapField (App "Paren" (List [App "()" (List []),+    Application (List [App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "const"])])]),App "Var" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "minBound"])])]),App "Lit" (List [App "()" (List+    []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+    FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "maxBound"])]),App "UnGuardedRhs" (List+    [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+    (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "head"])])]),App+    "List" (List [App "()" (List []),Reverse (MapCtor (Application (+    Concat (List [List [App "Con" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),CtorName])])])],MapField (App "Paren" (List [App "()" (+    List []),Application (List [App "Var" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "const"])])]),App "Var" (List [App "()" (List [])+    ,App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "maxBound"])])]),App "Lit" (List [App "()" (+    List []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+    FieldIndex])])])]))]))))])])]),App "Nothing" (List [])])])]]))] -- GENERATED STOP

@@ -30,21 +30,23 @@     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]+            [out ()+            ,out (Nothing :: Maybe (Overlap ()))+            ,out (IRule () Nothing context insthead :: InstRule ())+            ,f body]+        where+            context = Just $ CxTuple ()+                [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]+            ty = TyParen () $ foldl (TyApp ())+                (TyCon () $ UnQual () $ Ident () $ dataName input)+                (map tyVar $ dataDeclVars input)+            insthead = IHApp () (IHCon () $ UnQual () $ Ident () hd) ty      f (Application (f -> OList xs)) =-        foldl1 (\a b -> OApp "App" [a,b]) xs+        foldl1 (\a b -> OApp "App" [OApp "()" [],a,b]) xs      f (MapCtor dsl) = OList  [applyEnv dsl env{envCtor=c}          |  c <- dataCtors input]

@@ -2,6 +2,7 @@  module Data.Derive.DSL.Derive(derive) where +import Control.Arrow import Data.Derive.DSL.HSE import Data.Derive.DSL.DSL import Data.Derive.DSL.Apply@@ -24,18 +25,32 @@   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+guess (OApp "InstDecl" [_,OApp "Nothing" [],rule,decls])+    | OApp "IRule" [_, OApp "Nothing" [], ctx, ihead] <- unparen rule+    , (name, types) <- unInstHead ihead+    , OApp "UnQual" [_, OApp "Ident" [_, OString name]] <- name+    , [OApp "TyParen" [_,OApp "TyApp"+        [_,OApp "TyCon" [_,OApp "UnQual" [_,OApp "Ident" [_,OString nam]]]+        ,OApp "TyVar" [_,OApp "Ident" [_,OString var]]]]] <- types     , 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]+    = [Guess $ Instance (unContext ctx) name y | Guess y <- guess decls]     where-        unparenA (OApp "ParenA" [x]) = unparenA x-        unparenA x = x+        unContext (OApp "Just" [x])+            | OApp "CxSingle" [_,x] <- x = unClass x+            | OApp "CxTuple" [_,OList xs] <- x = concatMap unClass xs+        unContext x = [] +        unClass (OApp "ClassA" [_,OApp "UnQual" [_,OApp "Ident" [_,OString x]],_]) = [x]+        unClass _ = []++        unInstHead (OApp "IHCon" [_,  name]) = (name, [])+        unInstHead (OApp "IHInfix" [_, ty, name]) = (name, [ty])+        unInstHead (OApp "IHParen" [_, x]) = unInstHead x+        unInstHead (OApp "IHApp" [_, hd, ty]) = second (++[ty]) $ unInstHead hd++        unparen (OApp p [_, x]) | "Paren" `isInfixOf` p = unparen x+        unparen x = x+ guess (OList xs) = guessList xs guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)     @@ -93,22 +108,22 @@         diffs [] = []  -gssFold o@(OApp op [x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)+gssFold o@(OApp op [pre,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+        follow dir (OApp op2 [pre2,a,m2,b]) | op == op2 && pre == pre2 && 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])+        f dir xs | pre:_ <- [d | Guess d <- guess pre] = map (lift $ g pre) $ guess $ OList xs+            where g pre = Fold (App op $ List [pre,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]+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 _ = []     

@@ -23,10 +23,10 @@  -- data Sample a = First | Second a a | Third a sample :: Input-sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs []+sample = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ name "Sample") (tyVarBind "a")) ctrs Nothing     where         ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]-        ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ tyVar "a"+        ctr s i = QualConDecl () Nothing Nothing $ ConDecl () (name s) $ replicate i $ tyVar "a"   ---------------------------------------------------------------------@@ -57,7 +57,7 @@ toInput x = x  -type Out = [Decl]+type Out = [Decl ()]   

@@ -17,7 +17,7 @@   syb :: Data a => DSL -> Maybe a-syb = dsimple & dlistAny & dapp -- & derr+syb = dsimple & dlistAny & dapp -- & (\x -> error $ "Failed to generate for SYB, " ++ show x)  lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a) lift f = maybe Nothing id . cast . f@@ -66,14 +66,14 @@ dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle  -dinstance :: DSL -> Maybe Decl+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+    let ctx = ClassA () (UnQual () $ Ident () "Data") [TyVar () $ Ident () "d_type"]+    let rule = IRule () Nothing (Just (CxSingle () ctx))+                (IHApp () (IHCon () (UnQual () $ Ident () name)) (TyVar () $ Ident () "d_type"))+    return $ InstDecl () Nothing rule bod   dstring :: DSL -> Maybe String@@ -82,29 +82,29 @@     return x  -dmapctor :: DSL -> Maybe Exp+dmapctor :: DSL -> Maybe (Exp ()) dmapctor x = do-    App "List" (List [MapCtor x]) <- return x+    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")))]+    return $ ListComp () x [QualStmt () $ Generator () (PVar () $ Ident () "d_ctor")+        (H.App () (v "d_dataCtors") (Paren () $ ExpTypeSig () (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 :: DSL -> Maybe (Exp ())+dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorArity,ShowInt CtorArity])])) = Just $ Paren () $ H.App () (v "d_ctorArity") (v "d_ctor")+dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt 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 () (H.App () (v "d_ctorValue") (v "d_ctor")) (TyVar () $ Ident () "d_type") dsingle _ = Nothing  -dapplication :: DSL -> Maybe Exp+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:y:z) = f (App "App" (List [App "()" $ List [],x,y]) : z)         f [x] = x  -v = Var . UnQual . Ident+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"]]

@@ -24,36 +24,56 @@  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+    List [Instance ["Typeable"] "Data" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+    (List []),List [App "Match" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "gfoldl"]),List [App "PVar" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "k"])]),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "r"])]),App "PVar" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "x"])])],App+    "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"+    (List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "r"])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (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+    App "()" (List []),App "PatBind" (List [App "()" (List []),App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "gunfold"])]),App "UnGuardedRhs" (List [App "()" (List+    []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "error"])])]),App "Lit" (List [App "()"+    (List []),App "String" (List [App "()" (List []),Concat (List [+    String "Data.gunfold not implemented on abstract data type: ",+    DataName]),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+    )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"+    (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "toConstr"])]),App "UnGuardedRhs" (List [App "()" (List []),App+    "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+    ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "error"])])]),App "Lit" (List [App "()" (+    List []),App "String" (List [App "()" (List []),Concat (List [+    String "Data.gunfold not implemented on abstract data type: ",+    DataName]),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+    )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"+    (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "dataTypeOf"])]),App "UnGuardedRhs" (List [App "()" (List []),App+    "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+    ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "error"])])]),App "Lit" (List [App "()" (+    List []),App "String" (List [App "()" (List []),Concat (List [+    String "Data.gunfold not implemented on abstract data type: ",+    DataName]),Concat (List [String     "Data.gunfold not implemented on abstract data type: ",DataName])]-    )])])]),App "Nothing" (List [])])])])]+    )])])]),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"]]+context :: FullDataDecl -> Context () -> Context ()+context d _ = CxTuple () [ClassA () (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]

@@ -6,7 +6,6 @@  instance Default a => Default (Sample a) where     def = head [First, Second (const def 1) (const def 2), Third (const def 1)]- -}  -- GENERATED START@@ -18,15 +17,22 @@ 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 [])])])])]+    List [Instance ["Default"] "Default" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "def"])]),App "UnGuardedRhs" (List [App+    "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "head"])])]),App "List" (+    List [App "()" (List []),MapCtor (Application (Concat (List [List+    [App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"+    (List []),App "Ident" (List [App "()" (List []),CtorName])])])],+    MapField (App "Paren" (List [App "()" (List []),Application (List+    [App "Var" (List [App "()" (List []),App "UnQual" (List [App "()"+    (List []),App "Ident" (List [App "()" (List []),String "const"])])+    ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String "def"]+    )])]),App "Lit" (List [App "()" (List []),App "Int" (List [App+    "()" (List []),FieldIndex,ShowInt 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

@@ -31,75 +31,122 @@ 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+    List [Instance [] "Enum" (App "Just" (List [List [App "InsDecl" (+    List [App "()" (List []),App "FunBind" (List [App "()" (List []),+    Concat (List [MapCtor (App "Match" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "toEnum"]),List [App+    "PLit" (List [App "()" (List []),App "Signless" (List [App "()" (+    List [])]),App "Int" (List [App "()" (List []),CtorIndex,ShowInt+    CtorIndex])])],App "UnGuardedRhs" (List [App "()" (List []),App+    "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+    (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+    []])]),App "Nothing" (List [])])),List [App "Match" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String+    "toEnum"]),List [App "PVar" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "n"])])],App "UnGuardedRhs" (List+    [App "()" (List []),App "InfixApp" (List [App "()" (List []),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "error"])])]),App+    "QVarOp" (List [App "()" (List []),App "UnQual" (List [App "()" (+    List []),App "Symbol" (List [App "()" (List []),String "$"])])]),+    Fold (App "InfixApp" (List [App "()" (List []),Head,App "QVarOp" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Symbol" (List [App "()" (List []),String "++"])])]),Tail])) (+    List [App "Lit" (List [App "()" (List []),App "String" (List [App+    "()" (List []),String "toEnum ",String "toEnum "])]),App "App" (+    List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "show"])])]),App "Var" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "n"])])])]),App "Lit" (List [App "()" (List []),+    App "String" (List [App "()" (List []),Concat (List [String+    ", not defined for ",DataName]),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 [])])]])])])]])])]-    )]+    )]])])]),App "InsDecl" (List [App "()" (List []),App "FunBind" (+    List [App "()" (List []),MapCtor (App "Match" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),String "fromEnum"])+    ,List [App "PParen" (List [App "()" (List []),App "PRec" (List [+    App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),CtorName])]),List []])])],App+    "UnGuardedRhs" (List [App "()" (List []),App "Lit" (List [App "()"+    (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt+    CtorIndex])])]),App "Nothing" (List [])]))])]),App "InsDecl" (List+    [App "()" (List []),App "FunBind" (List [App "()" (List []),List [+    App "Match" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "succ"]),List [App "PVar" (List [App "()" (List [+    ]),App "Ident" (List [App "()" (List []),String "a"])])],App+    "UnGuardedRhs" (List [App "()" (List []),App "If" (List [App "()"+    (List []),App "InfixApp" (List [App "()" (List []),App "Var" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "b"])])]),App "QVarOp" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Symbol" (List [App "()" (List []),String "=="])])]),App "App"+    (List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "length"])])]),App "List" (List [App "()" (List []+    ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    CtorName])]),List []]))])])]),App "App" (List [App "()" (List []),+    App "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),String "toEnum"])])+    ]),App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+    List []),Int 0,ShowInt (Int 0)])])]),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "toEnum"])])]),App "Paren" (List [App "()" (List []),App+    "InfixApp" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "b"])])]),App "QVarOp" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+    List [App "()" (List []),String "+"])])]),App "Lit" (List [App+    "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+    Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App+    "()" (List []),List [App "PatBind" (List [App "()" (List []),App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),+    App "App" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "fromEnum"])])]),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "a"])])])])]),App "Nothing" (List+    [])])]])])])]])]),App "InsDecl" (List [App "()" (List []),App+    "FunBind" (List [App "()" (List []),List [App "Match" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String "pred"+    ]),List [App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "a"])])],App "UnGuardedRhs" (List [App+    "()" (List []),App "If" (List [App "()" (List []),App "InfixApp" (+    List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "b"])])]),App "QVarOp" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+    "()" (List []),String "=="])])]),App "Lit" (List [App "()" (List [+    ]),App "Int" (List [App "()" (List []),Int 0,ShowInt (Int 0)])])])+    ,App "App" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "toEnum"])])]),App "Paren" (List [App+    "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "length"])])]),App "List"+    (List [App "()" (List []),MapCtor (App "RecConstr" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),CtorName])]),List []]))])])])]),App "App" (+    List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "toEnum"])])]),App "Paren" (List [App "()" (List [+    ]),App "InfixApp" (List [App "()" (List []),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "b"])])]),App "QVarOp" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Symbol"+    (List [App "()" (List []),String "-"])])]),App "Lit" (List [App+    "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+    Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App+    "()" (List []),List [App "PatBind" (List [App "()" (List []),App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),+    App "App" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "fromEnum"])])]),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (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

@@ -46,22 +46,22 @@ 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]+mkFold :: DataDecl -> [Decl ()]+mkFold d | isIdent $ dataDeclName d = [TypeSig () [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)]+        f i c = Match () (name n) pat (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 :: 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]+        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)

@@ -36,30 +36,30 @@ 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]]+makeFromCtor :: DataDecl -> CtorDecl -> [Decl ()]+makeFromCtor d c | isIdent n = [TypeSig () [name from] typ, FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]                  | otherwise = []     where         n = ctorDeclName c         from = "from" ++ n -        typ = TyFun (dataDeclType d)+        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)+        match = Match () (name from) [pat] (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+        defMatch = Match () (name from) [PWildCard ()] (UnGuardedRhs () err) Nothing+        err = App () (var "error") $ Lit () $ let s = from ++ " failed, not a " ++ n in String () s (show s)  -tyTuple [] = TyCon $ Special UnitCon+tyTuple [] = TyCon () $ Special () $ UnitCon () tyTuple [x] = x-tyTuple xs = TyTuple Boxed xs+tyTuple xs = TyTuple () Boxed xs  -valTuple [] = Con $ Special UnitCon+valTuple [] = Con () $ Special () $ UnitCon () valTuple [x] = x-valTuple xs = Tuple Boxed xs+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)

@@ -28,13 +28,13 @@ 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 []+makeHasField :: DataDecl -> String -> [Decl ()]+makeHasField d field = if isIdent field then [TypeSig () [name has] typ, binds has ms] else []     where         has = "has" ++ title field-        typ = TyFun (dataDeclType d) (tyCon "Bool")+        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"]+        ms | null no = [match (PWildCard ()) "True"]+           | otherwise = [match (PRec () (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match (PWildCard ()) "False"]

@@ -12,15 +12,15 @@  data Derivation = Derivation     {derivationName :: String-    ,derivationOp :: Type -> (String -> Decl) -> FullDataDecl -> Either String [Decl]+    ,derivationOp :: Type () -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]     }  -derivationParams :: String -> ([Type] -> (String -> Decl) -> FullDataDecl -> Either String [Decl]) -> Derivation+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 :: String -> (FullDataDecl -> Either String [Decl ()]) -> Derivation derivationCustom name op = derivationParams name $ \ty grab decs -> op decs  @@ -28,22 +28,19 @@ derivationDSL name dsl = derivationCustomDSL name (const id) dsl  -derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation+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 :: (FullDataDecl -> Exp () -> Exp ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()]) customSplice custom d = transformBi f     where-        f (SpliceExp (ParenSplice x)) = custom d x+        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+customContext :: (FullDataDecl -> Context () -> Context ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])+customContext custom ds = transformBi (custom ds)

@@ -2,7 +2,7 @@ {-     This module is not written/maintained by the usual Data.Derive author. -    MAINTAINER: Twan van Laarhoven +    MAINTAINER: Twan van Laarhoven     EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"      Please send all patches to this module to Neil (ndmitchell -at- gmail),@@ -34,21 +34,21 @@ -- Information datatype, public interface  -- | An expression representing a traversal of a subpart of the data-type Trav = Exp+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+        { 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@@ -57,10 +57,10 @@         , 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]+        , traversalFunc   = \x y -> appP (Var () x) y+        , traversalPlus   = \x y -> apps (Con () $ Special () (Cons ())) [paren x, paren y]         , traverseArrow   = Nothing-        , traverseTuple   = Tuple Boxed+        , traverseTuple   = Tuple () Boxed         , traverseCtor    = \x y -> apps (con x) (map paren y)         , traverseFunc    = undefined         }@@ -84,92 +84,100 @@  -- | Derivation for a Traversable like class with just 1 method traversalDerivation1 :: TraveralType -> String -> Derivation-traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm) +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 :: 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]  +-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]+-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])+ -- | 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)]+traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances (Decl ())] -> [Decl ()]+traversalInstance tt nameBase dat bodyM = -- [simplify $ InstDecl () Nothing [] ctx nam args (map InsDecl body)]+      [ simplify $ InstDecl () Nothing instRule (Just $ map (InsDecl ()) body) ]     where+        instRule = IRule () Nothing (Just ctx) instHead+        instHead = foldr (flip (IHApp ())) (IHCon () nam) args         (body, required) = runWriter (sequence bodyM)-        ctx  = [ ClassA (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))+        ctx  = CxTuple ()+               [ 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-+        args = TyParen () (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter +-- Match SrcLoc Name [Pat] (Maybe Type) Rhs (Maybe Binds)+-- Match l (Name l) [Pat l] (Rhs l) (Maybe (Binds l)) -- | Derive a 'traverse' like function-deriveTraversal :: TraveralType -> DataDecl -> WithInstances Decl+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+        fun  = (\xs -> FunBind () [Match () nam a b c | Match () _ a b c <- 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+        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 :: 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))+    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 :: 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)+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+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 :: 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)))+             Lambda () [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"+           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..]@@ -190,13 +198,13 @@ traverseArg :: TraveralType -> Int -> Trav -> Trav traverseArg tt n e   =  traversalFunc tt (traversalNameN tt n) e -traversalNameN :: TraveralType -> Int -> QName+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+        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

@@ -22,12 +22,12 @@ makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d  -makeIsCtor :: DataDecl -> CtorDecl -> [Decl]+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]]+        [TypeSig () [name nam] (TyFun () (dataDeclType d) (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+        match = Match () (name nam) [PParen () $ PRec () (qname $ ctorDeclName c) []] (UnGuardedRhs () $ con "True") Nothing+        defMatch = Match () (name nam) [PWildCard ()] (UnGuardedRhs () $ con "False") Nothing

@@ -18,7 +18,7 @@ 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,+    (~=), var, pVar, con, strE, strP, apps, qname,     ctorDeclFields, ctorDeclName, dataDeclCtors)  {-@@ -41,74 +41,87 @@  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 [])]))])])])]+    List [Instance ["JSON"] "JSON" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+    (List []),List [App "Match" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),String "readJSON"]),List [App "PParen" (+    List [App "()" (List []),App "PApp" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "JSObject"])]),List [App "PVar" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),String "x"])])]])])+    ],App "UnGuardedRhs" (List [App "()" (List []),App "SpliceExp" (+    List [App "()" (List []),App "ParenSplice" (List [App "()" (List [+    ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String+    "readJSON"])])])])])]),App "Nothing" (List [])]),App "Match" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "readJSON"]),List [App "PWildCard" (List [App "()" (List [])])],+    App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+    "()" (List []),App "Con" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "Error"])])]),App "Lit" (List [App "()" (List []),App+    "String" (List [App "()" (List []),String "...",String "..."])])])+    ]),App "Nothing" (List [])])]])]),App "InsDecl" (List [App "()" (+    List []),App "FunBind" (List [App "()" (List []),MapCtor (App+    "Match" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "showJSON"]),List [App "PParen" (List [App "()" (+    List []),App "PApp" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),CtorName]+    )]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (+    List [App "()" (List []),Concat (List [String "x",ShowInt+    FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []+    ),App "SpliceExp" (List [App "()" (List []),App "ParenSplice" (+    List [App "()" (List []),App "App" (List [App "()" (List []),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "showJSON"])])]),+    App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+    List []),CtorIndex,ShowInt CtorIndex])])])])])]),App "Nothing" (+    List [])]))])])]]))] -- GENERATED STOP  -- ^ 'Derivation' for 'JSON' -custom :: FullDataDecl -> [Decl] -> [Decl]+custom :: FullDataDecl -> [Decl ()] -> [Decl ()] custom = customSplice splice -splice :: FullDataDecl -> Exp -> Exp+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 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 :: 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)]]+    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]+mkShowPlainFields :: FieldDecl -> Exp ()+mkShowPlainFields fs = mkJSArray $ H.List ()+    [H.App () (var "showJSON") xi | xi <- vars "x" fs] -mkShowRecordFields :: FieldDecl -> Exp-mkShowRecordFields fs = mkJSObject $ H.List-    [ H.Tuple H.Boxed [strE fn, var "showJSON" `H.App` xi]+mkShowRecordFields :: FieldDecl -> Exp ()+mkShowRecordFields fs = mkJSObject $ H.List ()+    [ H.Tuple () H.Boxed [strE fn, H.App () (var "showJSON") xi]     | ((fn, _), xi) <- zip fs (vars "x" fs)]  ------------------------------------------------------------------------------ -- readJSON -mkRead :: FullDataDecl -> Exp+mkRead :: FullDataDecl -> Exp () mkRead (_, d) = let-    readError = con "Error" `H.App` strE "malformed JSON for type ...: ..."+    readError = H.App () (con "Error") $ strE "malformed JSON for type ...: ..."   in-    H.Case (var "fromJSObject" `H.App` var "x") $+    H.Case () (H.App () (var "fromJSObject") $ var "x") $     map mkReadCtor (dataDeclCtors d) ++-    [H.Alt H.sl H.PWildCard (H.UnGuardedRhs readError) Nothing]+    [H.Alt () (H.PWildCard ()) (H.UnGuardedRhs () readError) Nothing] -mkReadCtor :: CtorDecl -> Alt+mkReadCtor :: CtorDecl -> Alt () mkReadCtor c = let     cn = ctorDeclName c     fs = ctorDeclFields c@@ -116,50 +129,50 @@     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+    H.Alt () (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")+mkReadRecord :: String -> FieldDecl -> Exp ()+mkReadRecord cn fs = H.Do () $+    [H.Generator () (H.PApp () (qname "JSObject") [pVar "z"])+          (H.App () (var "return") $ var "y")] +++    [H.LetStmt () $ H.BDecls () [H.PatBind () (pVar "d")+          (H.UnGuardedRhs () $ H.App () (var "fromJSObject") $ 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 $+mkReadRecordField :: String -> Pat () -> (String, Type ()) -> Stmt ()+mkReadRecordField cn xi (fn, _) = H.Generator () xi $     apps (var "maybe") [-        var "fail" `H.App` strE (unwords ["readJSON: missing field", fn,+        H.App () (var "fail") $ 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")] +++mkReadPlain :: String -> FieldDecl -> Exp ()+mkReadPlain cn fs = H.Do () $+    [H.Generator () (H.PApp () (qname "JSArray") [H.PList () (pVars "x" fs)])+        (H.App () (var "return") $ var "y")] ++     mkReadTrailer cn fs -mkReadTrailer :: String -> FieldDecl -> [Stmt]+mkReadTrailer :: String -> FieldDecl -> [Stmt ()] mkReadTrailer cn fs =-    [ H.Generator sl yi (var "readJSON" `H.App` xi)+    [ H.Generator () yi (H.App () (var "readJSON") xi)     | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++-    [H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)]+    [H.Qualifier () $ H.App () (var "return") $ apps (con cn) (vars "y" fs)]  ------------------------------------------------------------------------------ -- utilites -mkJSObject :: Exp -> Exp-mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e)+mkJSObject :: Exp () -> Exp ()+mkJSObject e = H.App () (con "JSObject") (H.App () (var "toJSObject") e) -mkJSArray :: Exp -> Exp-mkJSArray e = con "JSArray" `H.App` e+mkJSArray :: Exp () -> Exp ()+mkJSArray e = H.App () (con "JSArray") e -vars :: String -> FieldDecl -> [Exp]+vars :: String -> FieldDecl -> [Exp ()] vars pre fs = [var (pre ++ show i) | i <- [1..length fs]] -pVars :: String -> FieldDecl -> [Pat]+pVars :: String -> FieldDecl -> [Pat ()] pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]

@@ -27,12 +27,13 @@ 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 []+makeLazySetField :: DataDecl -> String -> [Decl ()]+makeLazySetField d field = if isIdent field then [TypeSig () [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else []     where         fun = "set" ++ title field-        typ = t `TyFun` (dataDeclType d `TyFun` dataDeclType d)+        tyFun = TyFun ()+        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")]+        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")]

@@ -29,8 +29,8 @@ 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 []+makeLensField :: DataDecl -> String -> [Decl ()]+makeLensField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []     where         ref = "lens" ++ title field         typ = tyApps (tyCon "Lens") [dataDeclType d, t]@@ -38,4 +38,4 @@          bod = apps (var "lens")             [var field-            ,Paren $ Lambda sl [pVar "x",pVar "v"] $ RecUpdate (var "v") [FieldUpdate (qname field) (var "x")]]+            ,Paren () $ Lambda () [pVar "x",pVar "v"] $ RecUpdate () (var "v") [FieldUpdate () (qname field) (var "x")]]

@@ -25,45 +25,69 @@ 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 [])])]])])])])]+    List [Instance ["Monoid"] "Monoid" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "mempty"])]),App "UnGuardedRhs" (List [+    App "()" (List []),App "App" (List [App "()" (List []),App "Var" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "head"])])]),App+    "List" (List [App "()" (List []),MapCtor (Application (Concat (+    List [List [App "Con" (List [App "()" (List []),App "UnQual" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+    ])])])],MapField (App "Paren" (List [App "()" (List []),+    Application (List [App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "const"])])]),App "Var" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "mempty"])])]),App "Lit" (List [App "()" (List []+    ),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+    FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App+    "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+    (List []),Concat (List [MapCtor (App "Match" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "mappend"]),List+    [App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+    [String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App+    "()" (List []),App "PApp" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    CtorName])]),MapField (App "PVar" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),Concat (List [String "y",ShowInt+    FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []+    ),Application (Concat (List [List [App "Con" (List [App "()" (List+    []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),CtorName])])])],MapField (App "Paren" (List [App+    "()" (List []),Application (List [App "Var" (List [App "()" (List+    []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "mappend"])])]),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]+    )])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+    [String "y",ShowInt FieldIndex])])])])])]))]))]),App "Nothing" (+    List [])])),List [App "Match" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "mappend"]),List [App+    "PWildCard" (List [App "()" (List [])]),App "PWildCard" (List [App+    "()" (List [])])],App "GuardedRhss" (List [App "()" (List []),List+    [App "GuardedRhs" (List [App "()" (List []),List [App "Qualifier"+    (List [App "()" (List []),App "InfixApp" (List [App "()" (List [])+    ,App "App" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "length"])])]),App "List" (List [App+    "()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+    List [App "()" (List []),String ">"])])]),App "Lit" (List [App+    "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+    Int 1)])])])])],App "App" (List [App "()" (List []),App "Var" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "error"])])]),App+    "Lit" (List [App "()" (List []),App "String" (List [App "()" (List+    []),Concat (List [String+    "Monoid.mappend: Different constructors for ",DataName]),Concat (+    List [String "Monoid.mappend: Different constructors for ",+    DataName])])])])])]]),App "Nothing" (List [])])]])])])]]))] -- GENERATED STOP

@@ -18,18 +18,25 @@ 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 [])]))])])])]+    List [Instance ["NFData"] "NFData" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+    (List []),MapCtor (App "Match" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "rnf"]),List [App+    "PParen" (List [App "()" (List []),App "PApp" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+    [String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (+    List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (+    List []),Head,App "QVarOp" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "seq"])])]),Tail])) (Concat (List [MapField (App "App" (+    List [App "()" (List []),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "rnf"])])]),App "Var" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),Concat (List [String "x",ShowInt FieldIndex])])])])])),+    List [App "Con" (List [App "()" (List []),App "Special" (List [App+    "()" (List []),App "UnitCon" (List [App "()" (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--}

@@ -29,14 +29,14 @@ 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 []+makeRefField :: DataDecl -> String -> [Decl ()]+makeRefField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []     where         ref = "ref" ++ title field-        typ = TyApp (tyCon "Ref") (dataDeclType d)+        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")]+        bod = RecConstr () (qname "Ref")+            [FieldUpdate () (qname "select") (var field)+            ,FieldUpdate () (qname "update") $ Lambda () [pVar "f",pVar "v"] $+                RecUpdate () (var "v") [FieldUpdate () (qname field) $ App () (var "f") $ Paren () $ App () (var field) (var "v")]             ]

@@ -28,38 +28,57 @@ 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 [])])]])])])]+    List [Instance ["Serial"] "Serial" (App "Just" (List [List [App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "series"])]),App "UnGuardedRhs" (List [+    App "()" (List []),Fold (App "InfixApp" (List [App "()" (List []),+    Tail,App "QVarOp" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Symbol" (List [App "()" (List []),String+    "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+    List [String "cons",ShowInt CtorArity])])])]),App "Con" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),CtorName])])])]))))]),App "Nothing" (+    List [])])]),App "InsDecl" (List [App "()" (List []),App "FunBind"+    (List [App "()" (List []),List [App "Match" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "coseries"]),List+    [App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "rs"])]),App "PVar" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "d"])])],App+    "UnGuardedRhs" (List [App "()" (List []),App "ListComp" (List [App+    "()" (List []),App "Lambda" (List [App "()" (List []),List [App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "t"])])],App "Case" (List [App "()" (List []),App "Var"+    (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "t"])])]),MapCtor (+    App "Alt" (List [App "()" (List []),App "PApp" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+    [String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [+    App "()" (List []),Application (Concat (List [List [App "Var" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),Concat (List [String "t",+    ShowInt CtorIndex])])])])],MapField (App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]+    )])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt"+    (List [App "()" (List []),App "Generator" (List [App "()" (List []+    ),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),Concat (List [String "t",ShowInt CtorIndex])])]),App+    "InfixApp" (List [App "()" (List []),Application (List [App "Var"+    (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),Concat (List [String "alts",+    ShowInt CtorArity])])])]),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "rs"])])]),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "d"])])])]),App "QVarOp" (List [App "()" (List [])+    ,App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "const"])])]),App "RecConstr" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),CtorName])]),List []])])])]))])]),App+    "Nothing" (List [])])]])])]]))] -- GENERATED STOP

@@ -56,79 +56,127 @@ 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+    List [Instance ["Serialize"] "Serialize" (App "Just" (List [List [+    App "InsDecl" (List [App "()" (List []),App "FunBind" (List [App+    "()" (List []),List [App "Match" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "put"]),List [App "PVar"+    (List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App+    "Case" (List [App "()" (List []),App "Var" (List [App "()" (List [+    ]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "x"])])]),MapCtor (App "Alt" (List [App "()"+    (List []),App "PApp" (List [App "()" (List []),App "UnQual" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+    ])]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (+    List [App "()" (List []),Concat (List [String "x",ShowInt+    FieldIndex])])]))]),App "UnGuardedRhs" (List [App "()" (List []),+    App "Do" (List [App "()" (List []),Concat (List [List [App+    "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "putTag"])])]),App "Lit" (List [App "()" (List []),App "Int" (List+    [App "()" (List []),CtorIndex,ShowInt CtorIndex])])])])],MapField+    (App "Qualifier" (List [App "()" (List []),App "App" (List [App+    "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "put"])])]),App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),Concat (List [String "x",ShowInt FieldIndex])])])])])]))]+    )])]),App "Nothing" (List [])]))])]),App "Just" (List [App+    "BDecls" (List [App "()" (List []),List [App "PatBind" (List [App+    "()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (+    List [App "()" (List []),String "useTag"])]),App "UnGuardedRhs" (+    List [App "()" (List []),App "InfixApp" (List [App "()" (List []),+    App "App" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "length"])])]),App "List" (List [App+    "()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+    List [App "()" (List []),String ">"])])]),App "Lit" (List [App+    "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+    Int 1)])])])]),App "Nothing" (List [])]),App "FunBind" (List [App+    "()" (List []),List [App "Match" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "putTag"]),List [App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),+    Application (List [App "Var" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "when"])])]),App "Var" (List [App "()" (List []),+    App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "useTag"])])]),App "Paren" (List [App "()" (List+    []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),Concat (List [String "putWord",ShowInt (Int 8)+    ])])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "x"])])])])])])]),App "Nothing" (List [])])]])]])])])]])]),App+    "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+    (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+    App "()" (List []),String "get"])]),App "UnGuardedRhs" (List [App+    "()" (List []),App "Do" (List [App "()" (List []),List [App+    "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+    List []),App "Ident" (List [App "()" (List []),String "i"])]),App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),String "getTag"])])])]),+    App "Qualifier" (List [App "()" (List []),App "Case" (List [App+    "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "i"])])]),Concat (List [MapCtor (App "Alt" (List [App "()"+    (List []),App "PLit" (List [App "()" (List []),App "Signless" (+    List [App "()" (List [])]),App "Int" (List [App "()" (List []),+    CtorIndex,ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()"+    (List []),App "Do" (List [App "()" (List []),Concat (List [+    MapField (App "Generator" (List [App "()" (List []),App "PVar" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    Concat (List [String "x",ShowInt FieldIndex])])]),App "Var" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "get"])])])])),List [App+    "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "return"])])]),App "Paren" (List [App "()" (List []),Application (+    Concat (List [List [App "Con" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+    []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+    )]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List+    [App "()" (List []),App "PWildCard" (List [App "()" (List [])]),+    App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+    "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "error"])])]),App "Lit" (List [App "()" (List []),App+    "String" (List [App "()" (List []),Concat (List [String+    "Corrupted binary data for ",DataName]),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-    [])])]])])])])])]+    List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [App+    "()" (List []),List [App "PatBind" (List [App "()" (List []),App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "useTag"])]),App "UnGuardedRhs" (List [App "()" (List [+    ]),App "InfixApp" (List [App "()" (List []),App "App" (List [App+    "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    String "length"])])]),App "List" (List [App "()" (List []),MapCtor+    (App "RecConstr" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),+    List []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Symbol" (List [App "()" (List []),+    String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (+    List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App+    "Nothing" (List [])]),App "PatBind" (List [App "()" (List []),App+    "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+    []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (List [+    ]),App "If" (List [App "()" (List []),App "Var" (List [App "()" (+    List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),String "useTag"])])]),App "Var" (List [App+    "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+    (List [App "()" (List []),Concat (List [String "getWord",ShowInt (+    Int 8)])])])]),App "App" (List [App "()" (List []),App "Var" (List+    [App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "return"])])]),App "Lit"+    (List [App "()" (List []),App "Int" (List [App "()" (List []),Int+    0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])]])])])])]]))+    ] -- GENERATED STOP

@@ -30,11 +30,12 @@ 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]+makeSetField :: DataDecl -> String -> [Decl ()]+makeSetField d field = [TypeSig () [name set] typ, bind set [pVar "v",pVar "x"] bod]     where         set = "set" ++ title field-        typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d)+        tyFun = TyFun ()+        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")]+        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

@@ -94,33 +94,38 @@     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"+        _ | 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+            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]]+-- alwaysActive :: Activation ()+-- alwaysActive = ActiveFrom () 0++make :: Bool -> (String -> DataDecl) -> Type () -> Type () -> Either String [Decl ()]+make uni grab from to =+    Right [InstDecl () Nothing instRule+        (Just [InsDecl () $ InlineSig () True Nothing (qname $ if uni then "uniplate" else "biplate"), InsDecl () ms])]     where+        headName = (UnQual () $ Ident () $ if uni then "Uniplate" else "Biplate")+        instRule = IRule () Nothing Nothing (foldr (flip (IHApp ())) (IHCon () headName) (from : [to | not uni]))         ty = grab $ tyRoot from-        match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) Nothing+        match pat bod = Match () (Ident () $ if uni then "uniplate" else "biplate") [pat] (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+             then FunBind () $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (App () (var "plate") (var "x")) | any isNothing bods]+             else PatBind () (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 :: (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+        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+        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)  @@ -143,12 +148,12 @@ ansJoin _ = Try  -type S a = State (Map.Map Type Ans) a+type S a = State (Map.Map (Type ()) Ans) a -run :: Type -> S a -> a+run :: Type () -> S a -> a run to act = evalState act (Map.singleton to Hit) -operator :: (String -> DataDecl) -> Type -> S Ans+operator :: (String -> DataDecl) -> Type () -> S Ans operator grab from = do     mp <- get     case Map.lookup from mp of@@ -165,7 +170,7 @@                 else put s >> fix ans2  -operator2 :: (String -> DataDecl) -> Type -> S Ans+operator2 :: (String -> DataDecl) -> Type () -> S Ans operator2 grab from     | isTyFun from = return Try     | Just from2 <- fromTyList from = fmap ansList $ operator grab from2@@ -174,27 +179,34 @@         Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs  -subst :: Type -> Decl -> Either Type [(String,[Type])]+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 :: 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 (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+substType :: Type () -> Decl () -> Type ()+substType ty (TypeDecl () dhead d) = fromTyParens $ transform f d     where+        vars = collect dhead         rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)-        f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep+        f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep         f x = x+        collect (DHead () _) = []+        collect (DHInfix () bind _) = [bind]+        collect (DHParen () h) = collect h+        collect (DHApp () h bind) = bind : collect h +clearAnn :: Functor f => f a -> f ()+clearAnn = fmap (const ()) -knownCtors :: [Decl]-knownCtors = map (fromParseResult . parseDecl)+knownCtors :: [Decl ()]+knownCtors = map (fromParseResult . fmap clearAnn . parseDecl)     ["data Int = Int"     ,"data Bool = Bool"     ,"data Char = Char"@@ -210,11 +222,12 @@     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"]] []+listCtor = DataDecl ()  (DataType ()) Nothing (DHApp () (DHead () $ Ident () "[]") (UnkindedVar () $ Ident () "a"))+    [QualConDecl () Nothing Nothing $ ConDecl () (Ident () "[]") []+    ,QualConDecl () Nothing Nothing $ ConDecl () (Ident () "(:)") [tyVar "a", TyList () $ tyVar "a"]] Nothing -tupleDefn :: Int -> Decl-tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map tyVar vars)] []+tupleDefn :: Int -> Decl ()+tupleDefn n = DataDecl () (DataType ()) Nothing dhead [QualConDecl () Nothing Nothing $ ConDecl () (Ident () s) (map tyVar vars)] Nothing     where s = "(" ++ replicate (n - 1) ',' ++ ")"           vars = ['v':show i | i <- [1..n]]+          dhead = foldr (flip (DHApp ())) (DHead () $ Ident () s) (map (UnkindedVar () . Ident ()) vars)

@@ -32,42 +32,71 @@  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 [])]-    ))])])]])]+    List [App "InstDecl" (List [App "()" (List []),App "Nothing" (List+    []),App "IRule" (List [App "()" (List []),App "Nothing" (List []),+    App "Just" (List [App "CxTuple" (List [App "()" (List []),List [+    App "ClassA" (List [App "()" (List []),App "UnQual" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String+    "Typeable"])]),List [App "TyVar" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "a"])])]]),App "ClassA" (+    List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "PlateAll"])]),List [+    App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "a"])]),App "TyVar" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),String "to"])])]]),App "ClassA"+    (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+    App "Ident" (List [App "()" (List []),String "Uniplate"])]),List [+    App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"+    (List []),String "to"])])]]),App "ClassA" (List [App "()" (List []+    ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+    "()" (List []),String "Typeable"])]),List [App "TyVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),String "to"])+    ])]])]])]),App "IHApp" (List [App "()" (List []),App "IHApp" (List+    [App "()" (List []),App "IHCon" (List [App "()" (List []),App+    "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+    List []),String "PlateAll"])])]),App "TyParen" (List [App "()" (+    List []),App "TyApp" (List [App "()" (List []),App "TyCon" (List [+    App "()" (List []),App "UnQual" (List [App "()" (List []),App+    "Ident" (List [App "()" (List []),DataName])])]),App "TyVar" (List+    [App "()" (List []),App "Ident" (List [App "()" (List []),String+    "a"])])])])]),App "TyVar" (List [App "()" (List []),App "Ident" (+    List [App "()" (List []),String "to"])])])]),App "Just" (List [+    List [App "InsDecl" (List [App "()" (List []),App "FunBind" (List+    [App "()" (List []),MapCtor (App "Match" (List [App "()" (List [])+    ,App "Ident" (List [App "()" (List []),String "plateAll"]),List [+    App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"+    (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+    [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+    "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+    [String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (+    List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (+    List []),Tail,App "QVarOp" (List [App "()" (List []),App "UnQual"+    (List [App "()" (List []),App "Symbol" (List [App "()" (List []),+    String "|+"])])]),Head])) (Concat (List [Reverse (MapField (App+    "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+    []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+    ,ShowInt FieldIndex])])])]))),List [App "App" (List [App "()" (+    List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+    App "()" (List []),App "Ident" (List [App "()" (List []),String+    "plate"])])]),App "Con" (List [App "()" (List []),App "UnQual" (+    List [App "()" (List []),App "Ident" (List [App "()" (List []),+    CtorName])])])])]]))]),App "Nothing" (List [])]))])])]])])] -- GENERATED STOP --custom (_,d) [InstDecl x1 x2 x3 _ x5 _ x7] = [InstDecl x1 x2 x3 x4 x5 x6 x7]+-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]+-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])+custom x [InstDecl () x2 (IParen () rule) mbDecl] = custom x [InstDecl () x2 rule mbDecl]+custom (_,d) [InstDecl () x2 (IRule () x3 _ ihead) x7] = [InstDecl () x2 (IRule () x3 x4 iheadOut) x7]     where+        (_x6, x5) = collect [] ihead         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"]]+        dd = (if null vars then id else TyParen ()) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)+        x4 = Just $ CxTuple () $+          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"]]+        iheadOut = foldr (flip (IHApp ())) (IHCon () x5) x6+        f v = [ClassA () (qname "Typeable") [tyVar v], ClassA () (qname "PlateAll") [tyVar v, tyVar "to"]]+        collect acc (IHCon () qname) = (acc, qname)+        collect acc (IHInfix () arg qname) = (arg:acc, qname)+        collect acc (IHParen () ih) = collect acc ih+        collect acc (IHApp () ih arg) = collect (arg:acc) ih

@@ -34,14 +34,14 @@ makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d  -makeUpdateField :: DataDecl -> String -> [Decl]+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")]]+        [TypeSig () [name upd] (TyFun () (TyParen () (TyFun () typF typF)) typR)+        ,bind upd [pVar "f",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (App () (var "f") (Paren () $ App () (var field) (var "x")))]+        ,TypeSig () [name set] (TyFun () typF 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+        typR = TyFun () (dataDeclType d) (dataDeclType d)         typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d

@@ -9,13 +9,13 @@ import Data.Maybe  -deriveDSL :: [Decl] -> Maybe DSL+deriveDSL :: [Decl ()] -> Maybe DSL deriveDSL = listToMaybe . derive  -applyDSL :: DSL -> DataDecl -> Either String [Decl]+applyDSL :: DSL -> DataDecl -> Either String [Decl ()] applyDSL dsl inp = Right $ apply dsl $ toInput inp  -dynamicDSL :: DSL -> Maybe [Decl]+dynamicDSL :: DSL -> Maybe [Decl ()] dynamicDSL = dslSYB

@@ -41,4 +41,4 @@         Right v -> return $ convert v  toFullDataDecl :: Dec -> FullDataDecl-toFullDataDecl x = (ModuleName "Todo", convert x)+toFullDataDecl x = (ModuleName () "Todo", convert x)

@@ -1,3 +1,4 @@+{-# LANGUAGE ViewPatterns #-}  module Derive.Derivation(wantDerive, performDerive, writeDerive) where @@ -16,35 +17,35 @@ --------------------------------------------------------------------- -- WHAT DO YOU WANT TO DERIVE -wantDerive :: [Flag] -> Module -> Module -> [Type]+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]+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 :: Module () -> Module () -> [Type ()] wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real  -moduleDerives :: Module -> [Type]+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 (DataDecl _ _ _ (fromDeclHead -> (name, vars)) _ deriv) = g name vars deriv+        f (GDataDecl _ _ _ (fromDeclHead -> (name, vars)) _ _ deriv) = g name vars deriv+        f (DerivDecl _ _ (fromIParen -> IRule _ _ _ (fromInstHead -> (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+        g name vars deriv = [TyCon () a `tyApps` (b:bs) | IRule _ _ _ (fromInstHead -> (a,bs)) <- map fromIParen $ maybe [] (\(Deriving _ xs) -> xs) deriv]+            where b = TyCon () (UnQual () name) `tyApps` map (tyVar . prettyPrint) vars   --------------------------------------------------------------------- -- ACTUALLY DERIVE IT -performDerive :: [Derivation] -> Module -> [Type] -> [String]+performDerive :: [Derivation] -> Module () -> [Type ()] -> [String] performDerive derivations modu = concatMap ((:) "" . f)     where         grab = getDecl modu@@ -61,13 +62,13 @@                 msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x  -getDecl :: Module -> (String -> Decl)+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 x@(DataDecl _ _ _ (fromDeclHead -> (name, _)) _ _) = [(prettyPrint name, x)]+        f x@(GDataDecl _ _ _ (fromDeclHead -> (name, _)) _ _ _) = [(prettyPrint name, x)]+        f x@(TypeDecl _ (fromDeclHead -> (name, _)) _) = [(prettyPrint name, x)]         f _ = []  @@ -80,7 +81,7 @@ --------------------------------------------------------------------- -- WRITE IT BACK -writeDerive :: FilePath -> ModuleName -> [Flag] -> [String] -> IO ()+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 ()

@@ -54,10 +54,10 @@             ]) ++             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 #-}"] ++@@ -82,7 +82,7 @@         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+        nam = case importSpecs x of Just (ImportSpecList _ False (IAbs _ _ y:_)) -> prettyPrint y ; _ -> name   wrap :: Int -> String -> [String]@@ -102,7 +102,7 @@ lexemes :: String -> [String] lexemes [] = [] lexemes x = a : lexemes b-    where (a,b) = lexeme x +    where (a,b) = lexeme x   lexeme :: String -> (String, String)

@@ -37,11 +37,12 @@     src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src     let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions}         real = parse src-        mine = parse $ uncomment src+        mine = parse $ uncomment src :: Module SrcSpanInfo     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+        [(getPointLoc sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]+    let blur = fmap (const ())+    let res = performDerive derivations (blur mine :: Module ()) $ wantDerive flags (blur real) (blur mine)+    writeDerive file (moduleName $ blur mine) flags res   uncomment :: String -> String

@@ -25,16 +25,16 @@ exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]  -- These must be first and in every set-priority = ["Eq"]+priority = []  -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"))])]-    []+listType :: Decl ()+listType = DataDecl () (DataType ()) Nothing (DHApp () (DHead () (Ident () "[]")) (UnkindedVar () $ Ident () "a"))+    [QualConDecl () Nothing Nothing (ConDecl () (Ident () "[]") [])+    ,QualConDecl () Nothing Nothing (ConDecl () (Ident () "Cons")+        [TyVar () (Ident () "a")+        ,TyApp () (TyCon () (UnQual () (Ident () "List"))) (TyVar () (Ident () "a"))])]+    Nothing   -- test each derivation@@ -62,14 +62,14 @@     when (res /= ExitSuccess) $ error "Failed to typecheck results"  -testFile :: [(String,Decl)] -> Derivation -> IO ()+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)+        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 

@@ -13,32 +13,32 @@  data Src = Src     {srcName :: String-    ,srcImport :: [ImportDecl]-    ,srcExample :: Maybe [Decl]-    ,srcTest :: [(Type,[Decl])]+    ,srcImport :: [ImportDecl ()]+    ,srcExample :: Maybe [Decl ()]+    ,srcTest :: [(Type (),[Decl ()])]     ,srcCustom :: Bool     }  -- skip the importPkg bits-srcImportStd :: Src -> [ImportDecl]+srcImportStd :: Src -> [ImportDecl ()] srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]  nullSrc = Src "" [] Nothing [] False  -readHSE :: FilePath -> IO Module+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+    return $ fmap (const ()) $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src  -data Pragma = Example Bool | Test Type+data Pragma = Example Bool | Test (Type ()) -asPragma :: Decl -> Maybe Pragma+asPragma :: Decl () -> Maybe Pragma asPragma (TypeSig _ [x] t)     | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"     | x ~= "test" = Just $ Test t

@@ -1,12 +1,14 @@-+{-# LANGUAGE PatternGuards #-} module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where -import Language.Haskell.Exts hiding (var,app,binds,paren)+import Language.Haskell.Exts hiding (var,app,binds,paren,FieldDecl)+import qualified Language.Haskell.Exts as HSE import Data.List import Data.Generics.Uniplate.Data import Data.Data import Data.Char import Data.Maybe+import Control.Arrow   infix 1 ?@@ -16,158 +18,164 @@   -- insert explicit foralls-foralls :: Type -> Type-foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x+foralls :: Type () -> Type ()+foralls x = TyForall () (Just $ map (UnkindedVar ()) $ nub [y | TyVar _ y <- universe x]) Nothing x   tyApps x [] = x-tyApps x (y:ys) = tyApps (TyApp x y) ys+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 (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 (TyTuple _ _ xs) = xs fromTyTuple x = [x] -fromTyParen (TyParen x) = fromTyParen x+fromTyParen (TyParen () x) = fromTyParen x fromTyParen x = x  fromTyParens = transform fromTyParen  tyRoot = prettyPrint . fst . fromTyApps . fromTyParen +isTyFun :: Type () -> Bool isTyFun TyFun{} = True isTyFun _ = False  isTyParen TyParen{} = True ; isTyParen _ = False -fromTyList (TyList x) = Just x-fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x+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)+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+        fExp :: Exp () -> Exp ()+        fExp (App _ op (List _ xs))+            | op ~= "length" = Lit () $ Int () (fromIntegral $ length xs) (show $ 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)+        fExp (InfixApp _ (Lit _ (Int _ i _)) op (Lit _ (Int _ j _)))+            | op ~= "-" = Lit () $ Int () (i - j) (show $ i-j)+            | op ~= "+" = Lit () $ Int () (i + j) (show $ 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)+        fExp (InfixApp _ (Lit _ (String _ x _)) op (Lit _ (String _ y _))) | op ~= "++" = Lit () $ String () (x ++ y) (show $ 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)+        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:_ <- good = 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)+        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+            | 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 (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 :: Type () -> Type ()+        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 :: Pat () -> Pat ()+        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+        fMatch :: Match () -> Match ()+        fMatch (Match sl nam pat (GuardedRhss _ [GuardedRhs _ [Qualifier _ x] bod]) decls)+            | x ~= "True" = fMatch $ Match sl nam pat (UnGuardedRhs () bod) decls+        fMatch (Match sl nam [PVar _ x] (UnGuardedRhs _ (Case _ (Var _ (UnQual _ x2)) [Alt _ pat (UnGuardedRhs _ y) Nothing])) decls)+            | x == x2 = fMatch $ Match sl nam [PParen () pat] (UnGuardedRhs () y) decls+        fMatch o@(Match a b c d bind) = fBinds (Match a b (minPat o c) d) bind +        fDecl :: Decl () -> Decl ()         fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind-        fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs+        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+        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 (PatBind _ (PVar _ x) (UnGuardedRhs _ bod) Nothing) = [(x,bod)]+                f (FunBind _ [Match _ x [PVar _ v] (UnGuardedRhs _ (Paren _ (App _ bod (Var _ v2)))) Nothing])+                    | UnQual () v == v2 = [(x,bod)]+                f (FunBind _ [Match sl x pat (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)]+                         , 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  +        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+                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 (Match sl nam pat (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 (UnQual _ (Ident _ ('(':xs@(x:_))))+    | x == ',' = Special () $ TupleCon () Boxed $ length xs+    | x /= ')' = UnQual () $ Symbol () $ init xs rename x = x  @@ -178,7 +186,7 @@ isAtom _ = False  -paren x = if isAtom x then x else Paren x+paren x = if isAtom x then x else Paren () x  sl = SrcLoc "" 0 0 @@ -188,16 +196,16 @@ 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+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 :: DataDecl -> Type () dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)  dataDeclFields :: DataDecl -> [String]@@ -205,96 +213,103 @@   -- A declaration that is either a DataDecl of GDataDecl-type DataDecl = Decl-type CtorDecl = Either QualConDecl GadtDecl-type FieldDecl = [(String, Type)]+type DataDecl = Decl ()+type CtorDecl = Either (QualConDecl ()) (GadtDecl ())+type FieldDecl = [(String, Type ())] -type FullDataDecl = (ModuleName, DataDecl)+type FullDataDecl = (ModuleName (), DataDecl)  -moduleName (Module _ name _ _ _ _ _) = name-moduleDecls (Module _ _ _ _ _ _ decls) = decls-moduleImports (Module _ _ _ _ _ imps _) = imps-modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas+moduleName (Module _ (Just (ModuleHead _ 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)+tyApp x xs = TyApp () (tyApp x $ init xs) (last xs)   tyFun [x] = x-tyFun (x:xs) = TyFun x (tyFun xs)+tyFun (x:xs) = TyFun () x (tyFun xs)   apps x [] = x-apps x (y:ys) = apps (App x y) ys+apps x (y:ys) = apps (App () x y) ys  -bind :: String -> [Pat] -> Exp -> Decl+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]+binds :: String -> [([Pat ()], Exp ())] -> Decl ()+binds n [([],e)] = PatBind () (pVar n) (UnGuardedRhs () e) Nothing+binds n xs = FunBind () [Match () (name n) p (UnGuardedRhs () e) Nothing | (p,e) <- xs]  -isDataDecl :: Decl -> Bool+isDataDecl :: Decl () -> Bool isDataDecl DataDecl{} = True isDataDecl GDataDecl{} = True isDataDecl _ = False +dataDeclName :: DataDecl -> String+dataDeclName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name+dataDeclName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name -dataDeclSrcLoc :: DataDecl -> SrcLoc-dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl-dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl+fromDeclHead :: DeclHead a -> (Name a, [TyVarBind a])+fromDeclHead (DHead _ n) = (n, [])+fromDeclHead (DHInfix _ x n) = (n, [x])+fromDeclHead (DHParen _ x) = fromDeclHead x+fromDeclHead (DHApp _ dh x) = second (++[x]) $ fromDeclHead dh -dataDeclContext :: DataDecl -> Context-dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx-dataDeclContext _ = error "dataDeclContext: not a DataDecl"+fromIParen :: InstRule a -> InstRule a+fromIParen (IParen _ x) = fromIParen x+fromIParen x = x -dataDeclName :: DataDecl -> String-dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name-dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name+fromInstHead :: InstHead a -> (QName a, [Type a])+fromInstHead (IHCon _ x) = (x, [])+fromInstHead (IHInfix _ t x) = (x, [t])+fromInstHead (IHParen _ x) = fromInstHead x+fromInstHead (IHApp l hd t) = second (++ [t]) $ fromInstHead hd + dataDeclVars :: DataDecl -> [String]-dataDeclVars (DataDecl _ _ _ _ vars _ _) = map f vars-    where f (KindedVar x _) = prettyPrint x-          f (UnkindedVar x) = prettyPrint x+dataDeclVars (DataDecl _ _ _ hd _ _) = map f $ snd $ fromDeclHead hd+    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+dataDeclVarsStar (DataDecl _ _ _ hd _ _) = mapMaybe f $ snd $ fromDeclHead hd+    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+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+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]+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) | HSE.FieldDecl _ 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-+declName :: Decl () -> String+declName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name+declName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name+declName (TypeDecl _ name _) = prettyPrint $ fst $ fromDeclHead name

@@ -1,10 +1,11 @@ {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}  module Language.Haskell.Convert(Convert, convert) where  import Language.Haskell as HS+import qualified Language.Haskell.Exts as HSE(FieldDecl(..)) import Language.Haskell.TH.Syntax as TH-import Language.Haskell.TH.Compat import Control.Exception import Data.Typeable import System.IO.Unsafe@@ -35,113 +36,128 @@   -instance Convert TH.Dec HS.Decl where+instance Convert TH.Dec (HS.Decl ()) where     conv x = case x of #if __GLASGOW_HASKELL__ >= 800-        DataD cxt n vs _ con ds -> f DataType cxt n vs con ds-        NewtypeD cxt n vs _ con ds -> f NewType cxt n vs [con] ds+        DataD cxt n vs _ con ds -> f (DataType ()) cxt n vs con ds+        NewtypeD cxt n vs _ con ds -> f (NewType ()) cxt n vs [con] ds         where-            f :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl-            f t cxt n vs con _ = DataDecl sl t (c cxt) (c n) (c vs) (c con) []+            f :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl ()+            f t cxt n vs con _ = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) Nothing #else-        DataD cxt n vs con ds -> f DataType cxt n vs con ds-        NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds+        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) []+            f :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl ()+            f t cxt n vs con ds = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) Nothing #endif -instance Convert TH.Name HS.TyVarBind where-    conv = UnkindedVar . c+            dh name [] = DHead () name+            dh name xs = DHApp () (dh name $ init xs) (last xs) -instance Convert TH.Name HS.Name where+instance Convert TH.Cxt (HS.Context ()) where+    conv = CxTuple () . map c++instance Convert (Maybe (HS.Context ())) TH.Cxt where+    conv Nothing = []+    conv (Just (CxSingle _ x)) = [c x]+    conv (Just (CxTuple _ xs)) = map c xs+    conv (Just (CxEmpty _)) = []++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+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.QualConDecl ()) where+    conv (ForallC vs cxt x) = QualConDecl () (Just $ c vs) (Just $ c cxt) (c x)+    conv x = QualConDecl () Nothing Nothing (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.Con (HS.ConDecl ()) where+    conv (NormalC n xs) = ConDecl () (c n) (c xs)+    conv (RecC n xs) = RecDecl () (c n) [HSE.FieldDecl () [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+instance Convert TH.StrictType (HS.Type ()) where #if __GLASGOW_HASKELL__ >= 800-    conv (Bang SourceUnpack SourceStrict, x) = TyBang UnpackedTy $ TyBang BangedTy $ c x-    conv (Bang SourceUnpack _, x) = TyBang UnpackedTy $ c x-    conv (Bang _ SourceStrict, x) = TyBang BangedTy $ c x+    conv (Bang SourceUnpack SourceStrict, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x+    conv (Bang SourceUnpack _, x) = TyBang () (NoStrictAnnot ()) (Unpack ()) $ c x+    conv (Bang _ SourceStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x     conv (Bang _ _, x) = c x #else-    conv (IsStrict, x) = TyBang BangedTy $ c x+    conv (IsStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x     conv (NotStrict, x) = c x #if __GLASGOW_HASKELL__ >= 704-    conv (Unpacked, x) = TyBang UnpackedTy $ c x+    conv (Unpacked, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x #endif #endif -instance Convert TH.Type HS.Type where-    conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t)-    conv (VarT x) = TyVar $ c x-    conv (ConT x) | ',' `elem` show x = TyTuple Boxed []-                  | otherwise = TyCon $ c x-    conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y)-    conv (ArrowT) = TyCon $ Special FunCon-    conv (AppT ListT x) = TyList $ c x-    conv (ListT) = TyCon $ Special ListCon-    conv (TupleT _) = TyTuple Boxed []+instance Convert TH.Type (HS.Type ()) where+    conv (ForallT xs cxt t) = TyForall () (Just $ c xs) (Just $ 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+        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) []+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])+        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)+instance Convert (HS.Decl ()) TH.Dec where+-- NEIL    conv (InstDecl _ _ _ cxt nam typ ds) = instanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds]+    conv (FunBind _ ms@(HS.Match _ nam _ _ _:_)) = FunD (c nam) (c ms)     conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds)     conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ) #if __GLASGOW_HASKELL__ >= 800     --  ! certainly BROKEN because it ignores contexts-    conv (DataDecl _ DataType ctx nam typ cs ds) =+    conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =       DataD (c ctx) (c nam) (c typ) Nothing (c cs) [] -- (c (map fst ds))-    conv (DataDecl _ NewType ctx nam typ [con] ds) =-      NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds)) +    conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =+      NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds)) #else-    conv (DataDecl _ DataType ctx nam typ cs ds) =-      DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds))-    conv (DataDecl _ NewType ctx nam typ [con] ds) =-      NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds))+    conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =+      DataD (c ctx) (c nam) (c typ) (c cs) []+    conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =+      NewtypeD (c ctx) (c nam) (c typ) (c con) [] #endif-      -instance Convert HS.QualConDecl TH.Con where-    conv (QualConDecl _ [] [] con) = c con-    conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con) -instance Convert HS.ConDecl TH.Con where-    conv (ConDecl nam typ) = NormalC (c nam) (c typ)-    conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r)-    conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs)+instance Convert (HS.QualConDecl ()) TH.Con where+    conv (QualConDecl _ Nothing Nothing con) = c con+    conv (QualConDecl _ vs cx con) = ForallC (c $ fromMaybe [] vs) (c cx) (c con) -instance Convert HS.Type TH.StrictType where+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 (HSE.FieldDecl ()) [TH.VarStrictType] where+    conv (HSE.FieldDecl _ names ty) = [(c name, bang, t) | let (bang,t) = c ty, name <- names]++instance Convert (HS.Type ()) TH.StrictType where #if __GLASGOW_HASKELL__ >= 800-    conv (TyBang BangedTy t) = (Bang NoSourceUnpackedness SourceStrict, c t)+    conv (TyBang _ BangedTy{} _ t) = (Bang NoSourceUnpackedness SourceStrict, c t) #else-    conv (TyBang BangedTy t) = (IsStrict, c t)+    conv (TyBang _ BangedTy{} _ t) = (IsStrict, c t) #if __GLASGOW_HASKELL__ >= 704-    conv (TyBang UnpackedTy t) = (Unpacked, c t)+    conv (TyBang _ _ Unpack{} t) = (Unpacked, c t) #else-    conv (TyBang UnpackedTy t) = (IsStrict, c t)+    conv (TyBang _ _ Unpack{} t) = (IsStrict, c t) #endif #endif #if __GLASGOW_HASKELL__ >= 800@@ -150,162 +166,167 @@     conv t = (NotStrict, c t) #endif -instance Convert ([HS.Name],HS.Type) [TH.VarStrictType] where+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.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.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+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.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.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)+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 (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) +    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]+    conv (ListComp _ x y) = CompE $ c $ y ++ [QualStmt () $ Qualifier () x] -instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where-    conv = undefined+instance Convert (HS.GuardedRhs ()) (TH.Guard, TH.Exp) where+    conv (GuardedRhs _ g x) = (conv g, conv x) -instance Convert HS.Binds [TH.Dec] where-    conv (BDecls x) = c x+instance Convert [HS.Stmt ()] TH.Guard where+    conv xs = PatG $ map conv xs -instance Convert (Maybe HS.Binds) [TH.Dec] where+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)+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.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.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.PatField ()) TH.FieldPat where+    conv (PFieldPat _ name pat) = (c name, c pat)+    conv (PFieldPun _ name) = (c name, c $ PVar () $ Ident () $ prettyPrint name)+    conv (PFieldWildcard _) = error "Can't convert PFieldWildcard" -instance Convert HS.QOp TH.Exp where-    conv (QVarOp x) = c $ Var x-    conv (QConOp x) = c $ Con x+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+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+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)+    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.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.FieldUpdate ()) TH.FieldExp where+    conv (FieldUpdate _ x y) = (c x, c y) -instance Convert HS.TyVarBind TH.Name where-    conv (UnkindedVar x) = c x+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+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+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)+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 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+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+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+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)+instance Convert (HS.Kind ()) TH.Kind where+    conv KindStar{} = StarT+    conv (KindFn _ x y) = AppT (AppT ArrowT (c x)) (c y) #endif #endif