derive 0.1.4 → 2.0.0

raw patch · 67 files changed

+3957/−2554 lines, 67 filesdep +bytestringdep +haskell-src-extsdep +uniplatedep −randomdep ~basesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, haskell-src-exts, uniplate

Dependencies removed: random

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Derive/All.hs +11/−6
• Data/Derive/Arbitrary.hs +68/−66
• Data/Derive/Arbitrary2.hs +0/−59
• Data/Derive/ArbitraryOld.hs +73/−0
• Data/Derive/Arities.hs +44/−0
• Data/Derive/Binary.hs +127/−27
• Data/Derive/BinaryDefer.hs +33/−41
• Data/Derive/BinaryOld.hs +0/−93
• Data/Derive/Bounded.hs +38/−30
• Data/Derive/Class/Arities.hs +5/−0
• Data/Derive/Class/Default.hs +5/−0
• Data/Derive/DSL/Apply.hs +75/−0
• Data/Derive/DSL/DSL.hs +112/−0
• Data/Derive/DSL/Derive.hs +141/−0
• Data/Derive/DSL/HSE.hs +115/−0
• Data/Derive/DSL/SYB.hs +114/−0
• Data/Derive/Data.hs +123/−84
• Data/Derive/Default.hs +33/−0
• Data/Derive/Enum.hs +45/−39
• Data/Derive/EnumCyclic.hs +94/−56
• Data/Derive/Eq.hs +51/−42
• Data/Derive/Fold.hs +66/−0
• Data/Derive/Foldable.hs +31/−14
• Data/Derive/From.hs +46/−24
• Data/Derive/Functor.hs +33/−10
• Data/Derive/Has.hs +27/−28
• Data/Derive/Instance/Arities.hs +15/−0
• Data/Derive/Internal/Derivation.hs +41/−0
• Data/Derive/Internal/Instance.hs +35/−0
• Data/Derive/Internal/Traversal.hs +216/−0
• Data/Derive/Is.hs +31/−26
• Data/Derive/LazySet.hs +27/−30
• Data/Derive/Monoid.hs +47/−24
• Data/Derive/NFData.hs +30/−28
• Data/Derive/Ord.hs +84/−67
• Data/Derive/PlateDirect.hs +0/−57
• Data/Derive/PlateTypeable.hs +51/−41
• Data/Derive/Read.hs +160/−9
• Data/Derive/Ref.hs +36/−17
• Data/Derive/Serial.hs +59/−50
• Data/Derive/Set.hs +28/−22
• Data/Derive/Show.hs +71/−17
• Data/Derive/TTypeable.hs +0/−26
• Data/Derive/Traversable.hs +29/−8
• Data/Derive/Typeable.hs +61/−28
• Data/Derive/Uniplate.hs +0/−232
• Data/Derive/Update.hs +36/−28
• Data/DeriveDSL.hs +22/−0
• Data/DeriveGuess.hs +0/−413
• Data/DeriveTH.hs +24/−32
• Data/DeriveTraversal.hs +0/−200
• Derive.hs +0/−321
• Derive/Derivation.hs +382/−0
• Derive/Flags.hs +63/−0
• Derive/Generate.hs +119/−0
• Derive/Test.hs +90/−0
• Derive/Utils.hs +87/−0
• LICENSE +1/−1
• Language/Haskell.hs +242/−0
• Language/Haskell/Convert.hs +208/−0
• Language/Haskell/TH/All.hs +0/−2
• Language/Haskell/TH/Data.hs +16/−18
• Language/Haskell/TH/Helper.hs +10/−1
• Main.hs +31/−0
• Setup.hs +1/−42
• derive.cabal +49/−34
• derive.htm +45/−161

@@ -1,17 +1,22 @@ -- | This module provides convenience re-exports of all the standard -- Data.Derive derivations.-module Data.Derive.All (module D) where+module Data.Derive.All (Derivation, derivations, module D) where +import Data.Derive.Internal.Derivation++-- GENERATED START import Data.Derive.Arbitrary        as D-import Data.Derive.Arbitrary2       as D+import Data.Derive.ArbitraryOld     as D+import Data.Derive.Arities          as D import Data.Derive.Binary           as D import Data.Derive.BinaryDefer      as D-import Data.Derive.BinaryOld        as D import Data.Derive.Bounded          as D import Data.Derive.Data             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@@ -21,7 +26,6 @@ import Data.Derive.Monoid           as D import Data.Derive.NFData           as D import Data.Derive.Ord              as D-import Data.Derive.PlateDirect      as D import Data.Derive.PlateTypeable    as D import Data.Derive.Read             as D import Data.Derive.Ref              as D@@ -29,7 +33,8 @@ import Data.Derive.Set              as D import Data.Derive.Show             as D import Data.Derive.Traversable      as D-import Data.Derive.TTypeable        as D import Data.Derive.Typeable         as D-import Data.Derive.Uniplate         as D import Data.Derive.Update           as D+derivations :: [Derivation]+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeLazySet,makeMonoid,makeNFData,makeOrd,makePlateTypeable,makeRead,makeRef,makeSerial,makeSet,makeShow,makeTraversable,makeTypeable,makeUpdate]+-- GENERATED STOP

@@ -1,76 +1,78 @@-{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}---- | Derivation for 'Test.QuickCheck.Arbitrary'.------ Things to note:------ * The resulting instances do not implement @coarbitrary@, only--- @arbitrary@.------ * The resulting instances of @arbitrary@ generate each constructor--- of the data type with equal probability.------ * No form of size control is used. module Data.Derive.Arbitrary(makeArbitrary) where+{-+import "QuickCheck" Test.QuickCheck -import Language.Haskell.TH.All+example :: Custom +instance Arbitrary (Sample a) where+    arbitrary = do+        x <- choose (0::Int,length [First{},Second{},Third{}] - 1)+        case x of+            0 -> do return (First)+            1 -> do x1 <- arbitrary+                    x2 <- arbitrary+                    return (Second x1 x2)+            2 -> do x1 <- arbitrary+                    return (Third x1) -#ifdef GUESS+test :: State+instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where+    arbitrary = do x1 <- arbitrary+                   return (StateT x1)+-} -import Test.QuickCheck-import Data.DeriveGuess+import Data.Derive.DSL.HSE+import qualified Language.Haskell as H+import Data.List+import Data.Generics.PlateData -example = (,) "Arbitrary" [d|+-- GENERATED START -    instance Arbitrary a => Arbitrary (DataName a) where-        arbitrary = do-            x <- choose (0,3)-            case x of-                0 -> do return CtorZero-                1 -> do x1 <- arbitrary-                        return (CtorOne x1)-                2 -> do x1 <- arbitrary-                        x2 <- arbitrary-                        return (CtorTwo x1 x2)-                3 -> do x1 <- arbitrary-                        x2 <- arbitrary-                        return (CtorTwo' x1 x2)+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation -        coarbitrary CtorZero = variant 0-        coarbitrary (CtorOne x1) = variant 1 . coarbitrary x1-        coarbitrary (CtorTwo x1 x2) = variant 2 . coarbitrary x1 . coarbitrary x2-        coarbitrary (CtorTwo' x1 x2) = variant 3 . coarbitrary x1 . coarbitrary x2-    |]+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 "Nothing" (List []),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 [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"])])+    ]),MapCtor (App "Alt" (List [App "PLit" (List [App "Int" (List [+    CtorIndex])]),App "UnGuardedAlt" (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 "BDecls" (List [List []])]))])])]])]),App "BDecls" (+    List [List []])])])])]+-- GENERATED STOP -#endif+custom = customContext context -makeArbitrary :: Derivation-makeArbitrary = derivation arbitrary' "Arbitrary"-arbitrary' dat = [InstanceD (concat ([(map (\tdat -> (AppT (ConT (mkName-    "Arbitrary")) tdat)) (dataVars dat))])) (head [(AppT (ConT (mkName-    "Arbitrary")) (lK (dataName dat) (dataVars dat)))])[(ValD (VarP (mkName-    "arbitrary")) (NormalB (DoE [(BindS (VarP (mkName "x")) (AppE (VarE (mkName-    "choose")) (TupE [--- NOTE BIG TIME:-    (SigE (LitE (IntegerL 0)) (ConT (mkName "Int")))--- The above was generated by the 'guess' function to just be--- (LitE (IntegerL 0)) ...--- but we must annotate it with an Int type so that auto-generated--- instances actually work since otherwise we get an ambiguous type--- freak-out-    ,(LitE (IntegerL (toInteger (length (-    dataCtors dat) - 1))))]))),(NoBindS (CaseE (VarE (mkName "x")) ((map (\(-    ctorInd,ctor) -> (Match (LitP (IntegerL ctorInd)) (NormalB (DoE ((map (-    \field -> (BindS (VarP (mkName ("x" ++ show field))) (VarE (mkName-    "arbitrary")))) (id [1..ctorArity ctor]))++[(NoBindS (AppE (VarE (mkName-    "return")) (applyWith (ConE (mkName ("" ++ ctorName ctor))) ((map (\field-    -> (VarE (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))))]-    ++[]))) [])) (id (zip [0..] (dataCtors dat))))++[])))])) []),(FunD (mkName-    "coarbitrary") ((map (\(ctorInd,ctor) -> (Clause [(ConP (mkName ("" ++-    ctorName ctor)) ((map (\field -> (VarP (mkName ("x" ++ show field)))) (id [-    1..ctorArity ctor]))++[]))] (NormalB (foldl1With (VarE (mkName ".")) ([(-    AppE (VarE (mkName "variant")) (LitE (IntegerL ctorInd)))]++(map (\field ->-    (AppE (VarE (mkName "coarbitrary")) (VarE (mkName ("x" ++ show field))))) (-    id [1..ctorArity ctor]))++[]))) [])) (id (zip [0..] (dataCtors dat))))++[])-    )]]+-- Fix the context+-- C a b => Arbitrary a, Arbitrary b+-- a -> b => CoArbitrary a, Arbitrary b+context :: FullDataDecl -> Context+context (_,d) = nub $ concatMap (f True . fromBangType . snd) $ concatMap ctorDeclFields $ dataDeclCtors d+    where+        f b (TyVar x) = [ClassA (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar x]]+        f b (TyFun x y) = f (not b) x ++ f b y+        f b x = concatMap (f b) (children x)+

@@ -1,59 +0,0 @@-{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}---- | Derivation for 'Test.QuickCheck.Arbitrary' (version 2 of quickcheck.)------ * The resulting instances of @arbitrary@ generate each constructor--- of the data type with equal probability.------ * No form of size control is used.-module Data.Derive.Arbitrary2(makeArbitrary2) where--import Language.Haskell.TH.All---#ifdef GUESS--import Test.QuickCheck-import Data.DeriveGuess--example = (,) "Arbitrary2" [d|--    instance Arbitrary a => Arbitrary (DataName a) where-        arbitrary = do-            x <- choose (0,3)-            case x of-                0 -> do return CtorZero-                1 -> do x1 <- arbitrary-                        return (CtorOne x1)-                2 -> do x1 <- arbitrary-                        x2 <- arbitrary-                        return (CtorTwo x1 x2)-                3 -> do x1 <- arbitrary-                        x2 <- arbitrary-                        return (CtorTwo' x1 x2)-    |]--#endif--makeArbitrary2 :: Derivation-makeArbitrary2 = derivation arbitrary' "Arbitrary2"-arbitrary' dat = [InstanceD (concat ([(map (\tdat -> (AppT (ConT (mkName -    "Arbitrary")) tdat)) (dataVars dat))])) (head [(AppT (ConT (mkName -    "Arbitrary")) (lK (dataName dat) (dataVars dat)))])[(ValD (VarP (mkName -    "arbitrary")) (NormalB (DoE [(BindS (VarP (mkName "x")) (AppE (VarE (mkName-    "choose")) (TupE [--- NOTE BIG TIME:-    (SigE (LitE (IntegerL 0)) (ConT (mkName "Int")))--- The above was generated by the 'guess' function to just be--- (LitE (IntegerL 0)) ...--- but we must annotate it with an Int type so that auto-generated--- instances actually work since otherwise we get an ambiguous type--- freak-out-    ,(LitE (IntegerL (toInteger (length (-    dataCtors dat) - 1))))]))),(NoBindS (CaseE (VarE (mkName "x")) ((map (\(-    ctorInd,ctor) -> (Match (LitP (IntegerL ctorInd)) (NormalB (DoE ((map (-    \field -> (BindS (VarP (mkName ("x" ++ show field))) (VarE (mkName -    "arbitrary")))) (id [1..ctorArity ctor]))++[(NoBindS (AppE (VarE (mkName -    "return")) (applyWith (ConE (mkName ("" ++ ctorName ctor))) ((map (\field -    -> (VarE (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))))]-    ++[]))) [])) (id (zip [0..] (dataCtors dat))))++[])))])) [])]]

@@ -0,0 +1,73 @@+module Data.Derive.ArbitraryOld where+{-+import "QuickCheck-1.1.0.0" Test.QuickCheck(Arbitrary)++example :: Sample++instance Arbitrary a => Arbitrary (Sample a) where+    arbitrary = do+        x <- choose (0,length [First{},Second{},Third{}]-1)+        case x of+            0 -> do return (First)+            1 -> do x1 <- arbitrary+                    x2 <- arbitrary+                    return (Second x1 x2)+            2 -> do x1 <- arbitrary+                    return (Third x1)++    coarbitrary (First) = variant 0+    coarbitrary (Second x1 x2) = variant 1 . coarbitrary x1 . coarbitrary x2+    coarbitrary (Third x1) = variant 2 . coarbitrary x1++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArbitraryOld :: Derivation+makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld++dslArbitraryOld =+    List [Instance ["Arbitrary"] "Arbitrary" (List [App "InsDecl" (+    List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [+    String "arbitrary"])]),App "Nothing" (List []),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 [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 "Int" (List [CtorIndex])]),App "UnGuardedAlt" (+    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 "BDecls" (List [+    List []])]))])])]])]),App "BDecls" (List [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 "BDecls" (List [List []])]))])])])]+-- GENERATED STOP

@@ -0,0 +1,44 @@+module Data.Derive.Arities where+{-+import "derive" Data.Derive.Class.Arities++example :: Sample++instance Arities (Sample a) where+    arities _ = [const 0 First{}, const 2 Second{}, const 1 Third{}]++test :: []++instance Arities [a] where+    arities _ = [0,2]++test :: Bool++instance Arities Bool where+    arities _ = [0,0]++test :: Either++instance Arities (Either a b) where+    arities _ = [1,1]+-}++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArities :: Derivation+makeArities = derivationDSL "Arities" dslArities++dslArities =+    List [Instance [] "Arities" (List [App "InsDecl" (List [App+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [+    String "arities"]),List [App "PWildCard" (List [])],App "Nothing"+    (List []),App "UnGuardedRhs" (List [App "List" (List [MapCtor (+    Application (List [App "Var" (List [App "UnQual" (List [App+    "Ident" (List [String "const"])])]),App "Lit" (List [App "Int" (+    List [CtorArity])]),App "RecConstr" (List [App "UnQual" (List [App+    "Ident" (List [CtorName])]),List []])]))])]),App "BDecls" (List [+    List []])])]])])])]+-- GENERATED STOP

@@ -1,34 +1,134 @@--- NOTE: Cannot be guessed as is not inductive because of getWordN+module Data.Derive.Binary where+{-+import "binary" Data.Binary --- | Derivation for Data.Binary's Binary class for serializing values.--- The generated instances implement a very simple tagged data format.--- First, the (0-based) constructor number is stored, in the smallest--- of 0, 1, 2, or 4 bytes that can represent the entire range.  Then,--- the constructor's arguments are stored, in order, using the Binary--- instances in scope.-module Data.Derive.Binary(makeBinary) where+example :: Sample -import Language.Haskell.TH.All-import Data.List+instance Binary alpha => Binary (Sample alpha) where+    put x = case x of+        First          -> do putTag 0+        Second  x1 x2  -> do putTag 1 ; put x1 ; put x2+        Third   x1     -> do putTag 2 ; put x1+        where+            useTag = length [First{}, Second{}, Third{}] > 1+            putTag x = when useTag (putWord8 x) -makeBinary :: Derivation-makeBinary = derivation derive "Binary"+    get = do+        i <- getTag+        case i of+            0 -> do return (First)+            1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)+            2 -> do x1 <- get ; return (Third x1)+            _ -> error "Corrupted binary data for Sample"+        where+            useTag = length [First{}, Second{}, Third{}] > 1+            getTag = if useTag then getWord8 else return 0 -derive dat =-        simple_instance "Binary" dat [funN "put" pbody, funN "get" gbody]-    where-        pbody = [ sclause [ctp ctor 'x'] (put_case nm ctor) | (nm,ctor) <- items ]-        put_case nm ctor = sequence__ (ptag (lit nm) : map (l1 "put") (ctv ctor 'x')) -        gbody = [sclause [] (gtag >>=: ("tag_" ->: case' (vr "tag_") (map get_case items)))]-        get_case (nm,ctor) = (lit nm, liftmk (ctc ctor) (replicate (ctorArity ctor) (vr "get")))+test :: List -        ctors = dataCtors dat-        nctors = length ctors-        items :: [(Integer,CtorDef)]-        items = zip [0..] ctors+instance Binary a => Binary (List a) where+    put x = case x of+        Nil -> putWord8 0+        Cons x1 x2 -> do putWord8 1; put x1; put x2 -        (ptag, gtag) | nctors <= 1     = (\_ -> return' unit, return' (lit (0::Integer)))-                     | nctors <= 256   = (l1 "putWord8", l0 "getWord8")-                     | nctors <= 65536 = (l1 "putWord16", l0 "getWord16")-                     | otherwise       = (l1 "putWord32", l0 "getWord32")+    get = do+        i <- getWord8+        case i of+            0 -> return Nil+            1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)+            _ -> error "Corrupted binary data for List"++test :: Assoced++instance Binary typ => Binary (Assoced typ) where+    put (Assoced x1 x2) = do put x1; put x2+    get = do x1 <- get; x2 <- get; return (Assoced x1 x2)+++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBinary :: Derivation+makeBinary = derivationDSL "Binary" dslBinary++dslBinary =+    List [Instance ["Binary"] "Binary" (List [App "InsDecl" (List [App+    "FunBind" (List [List [App "Match" (List [App "Ident" (List [+    String "put"]),List [App "PVar" (List [App "Ident" (List [String+    "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App+    "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" (+    List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List+    [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App+    "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt+    FieldIndex])])]))]),App "UnGuardedAlt" (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+    "BDecls" (List [List []])]))])]),App "BDecls" (List [List [App+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String+    "useTag"])]),App "Nothing" (List []),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 "BDecls" (List [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 "BDecls" (List [List []])])]])]])])]])]),App+    "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App+    "Ident" (List [String "get"])]),App "Nothing" (List []),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 "Int" (List [+    CtorIndex])]),App "UnGuardedAlt" (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 "BDecls" (List [List []])])),List [App "Alt" (List [+    App "PWildCard" (List []),App "UnGuardedAlt" (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+    "BDecls" (List [List []])])]])])])]])]),App "BDecls" (List [List [+    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String+    "useTag"])]),App "Nothing" (List []),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 "BDecls" (List [List []])]),App+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String+    "getTag"])]),App "Nothing" (List []),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 "BDecls" (List [List []])])]])])])])]+-- GENERATED STOP

@@ -1,48 +1,40 @@-{-# OPTIONS_GHC -fth -cpp #-}---- | Derivation for Neil Mitchell's BinaryDefer class.  XXX: do research, write useful haddock-module Data.Derive.BinaryDefer(makeBinaryDefer) where--import Language.Haskell.TH.All hiding (unit)--#ifdef GUESS--import Data.DeriveGuess-import Data.Binary.Defer--instance Eq (DataName a) where+module Data.Derive.BinaryDefer where+{-+import "binarydefer" Data.Binary.Defer -example = (,) "BinaryDefer" [d|+example :: Sample -    instance BinaryDefer a => BinaryDefer (DataName a) where-        bothDefer = defer [\ ~(CtorZero) -> unit CtorZero-                          ,\ ~(CtorOne x1) -> unit CtorOne << x1-                          ,\ ~(CtorTwo x1 x2) -> unit CtorTwo << x1 << x2-                          ,\ ~(CtorTwo' x1 x2) -> unit CtorTwo' << x1 << x2-                          ]+instance BinaryDefer a => BinaryDefer (Sample a) where+    bothDefer = defer [\ ~(First) -> unit First+                      ,\ ~(Second x1 x2) -> unit Second << x1 << x2+                      ,\ ~(Third x1) -> unit Third << x1+                      ] -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeBinaryDefer :: Derivation-makeBinaryDefer = derivation binarydefer' "BinaryDefer"-binarydefer' dat = [instance_context ["BinaryDefer"] "BinaryDefer" dat [ValD (-    VarP (mkName "bothDefer")) (NormalB (AppE (VarE (mkName "defer")) (ListE ((-    map (\(ctorInd,ctor) -> (LamE [(TildeP (ConP (mkName (ctorName ctor)) ((map-    (\field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++-    [])))] (foldr1With (VarE (mkName "<<")) ((map (\field -> (VarE (mkName ("x"-    ++ show field)))) (reverse [1..ctorArity ctor]))++[(AppE (VarE (mkName-    "unit")) (ConE (mkName (ctorName ctor))))]++[])))) (id (zip [0..] (-    dataCtors dat))))++[])))) []]]-    --{-    --derive dat = simple_instance "BinaryDefer" dat [funN "bothDefer" [ body ] ]-    where-        body = sclause [] (l1 "defer" (lst [ f ct | ct <- dataCtors dat ]))+makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer -        f ctor = LamE [TildeP (ctp ctor 'v')] $-                 foldl (l2 "<<") (l1 "unit" (ctc ctor)) (ctv ctor 'v')--}+dslBinaryDefer =+    List [Instance ["BinaryDefer"] "BinaryDefer" (List [App "InsDecl"+    (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [+    String "bothDefer"])]),App "Nothing" (List []),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+    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),+    MapField (App "PVar" (List [App "Ident" (List [Concat (List [+    String "x",ShowInt FieldIndex])])]))])])])],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 "BDecls" (List [+    List []])])])])]+-- GENERATED STOP

@@ -1,93 +0,0 @@--- NOTE: Cannot be guessed as is not inductive because of getWordN---- | Derivation for Data.Binary's Binary class for serializing values.--- The generated instances implement a very simple tagged data format.-{-# OPTIONS_GHC -fth -cpp #-}--module Data.Derive.BinaryOld(makeBinaryOld) where--import Language.Haskell.TH.All-import Data.List--#ifdef GUESS--import Data.DeriveGuess-import Yhc.Core.Internal.Binary--example = (,) "BinaryOld" [d|--    instance Binary a => Binary (DataName a) where-        put_ bh x = -            case x of-                CtorZero -> do-                    if useTag then putByte bh 0 else return ()-                CtorOne x1 -> do-                    if useTag then putByte bh 1 else return ()-                    put_ bh x1-                CtorTwo x1 x2 -> do-                    if useTag then putByte bh 2 else return ()-                    put_ bh x1-                    put_ bh x2-                CtorTwo' x1 x2 -> do-                    if useTag then putByte bh 3 else return ()-                    put_ bh x1-                    put_ bh x2-            where-                useTag = length [CtorZero{}, CtorOne{}, CtorTwo{}, CtorTwo'{}] > 1--        get bh = do-            h <- if useTag then getByte bh else return 0-            case h of-                0 -> do-                    return CtorZero-                1 -> do-                    x1 <- get bh-                    return (CtorOne x1)-                2 -> do-                    x1 <- get bh-                    x2 <- get bh-                    return (CtorTwo x1 x2)-                3 -> do-                    x1 <- get bh-                    x2 <- get bh-                    return (CtorTwo' x1 x2)-                _ -> fail "invalid binary data found"-            where-                useTag = length [CtorZero{}, CtorOne{}, CtorTwo{}, CtorTwo'{}] > 1-    |]--#endif---makeBinaryOld :: Derivation-makeBinaryOld = derivation binaryOld' "BinaryOld"-binaryOld' dat = [InstanceD (concat ([(map (\tdat -> (AppT (ConT (mkName-    "Binary")) tdat)) (dataVars dat))])) (head [(AppT (ConT (mkName "Binary"))-    (lK (dataName dat) (dataVars dat)))])[(FunD (mkName "put_") [(Clause [(VarP-    (mkName "bh")),(VarP (mkName "x"))] (NormalB (CaseE (VarE (mkName "x")) ((-    map (\(ctorInd,ctor) -> (Match (ConP (mkName ("" ++ ctorName ctor)) ((map (-    \field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[-    ])) (NormalB (DoE ([(NoBindS (CondE (VarE (mkName "useTag")) (applyWith (-    VarE (mkName "putByte")) [(VarE (mkName "bh")),(LitE (IntegerL ctorInd))])-    (AppE (VarE (mkName "return")) (TupE []))))]++(map (\field -> (NoBindS (-    applyWith (VarE (mkName "put_")) [(VarE (mkName "bh")),(VarE (mkName ("x"-    ++ show field)))]))) (id [1..ctorArity ctor]))++[]))) [])) (id (zip [0..] (-    dataCtors dat))))++[]))) [(ValD (VarP (mkName "useTag")) (NormalB (-    applyWith (VarE (mkName ">")) [(AppE (VarE (mkName "length")) (ListE ((map-    (\(ctorInd,ctor) -> ((flip RecConE []) (mkName ("" ++ ctorName ctor)))) (id-    (zip [0..] (dataCtors dat))))++[]))),(LitE (IntegerL 1))])) [])])]),(FunD (-    mkName "get") [(Clause [(VarP (mkName "bh"))] (NormalB (DoE [(BindS (VarP (-    mkName "h")) (CondE (VarE (mkName "useTag")) (AppE (VarE (mkName "getByte")-    ) (VarE (mkName "bh"))) (AppE (VarE (mkName "return")) (LitE (IntegerL 0)))-    )),(NoBindS (CaseE (VarE (mkName "h")) ((map (\(ctorInd,ctor) -> (Match (-    LitP (IntegerL ctorInd)) (NormalB (DoE ((map (\field -> (BindS (VarP (-    mkName ("x" ++ show field))) (AppE (VarE (mkName "get")) (VarE (mkName "bh"-    ))))) (id [1..ctorArity ctor]))++[(NoBindS (AppE (VarE (mkName "return")) (-    applyWith (ConE (mkName ("" ++ ctorName ctor))) ((map (\field -> (VarE (-    mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))))]++[]))) [])-    ) (id (zip [0..] (dataCtors dat))))++[(Match WildP (NormalB (AppE (VarE (-    mkName "fail")) (LitE (StringL "invalid binary data found")))) [])]++[])))]-    )) [(ValD (VarP (mkName "useTag")) (NormalB (applyWith (VarE (mkName ">"))-    [(AppE (VarE (mkName "length")) (ListE ((map (\(ctorInd,ctor) -> ((flip-    RecConE []) (mkName ("" ++ ctorName ctor)))) (id (zip [0..] (dataCtors dat)-    )))++[]))),(LitE (IntegerL 1))])) [])])])]]

@@ -1,36 +1,44 @@-{-# OPTIONS_GHC -fth -cpp #-}---- | Derive @Bounded@, as specified in the Haskell 98 Language Report.--- As an extension, we support deriving @Bounded@ for all data types.--- If the first or last constructor has non-zero arity, we call--- minBound (respectively, maxBound) recursively to fill in the--- fields.-module Data.Derive.Bounded(makeBounded) where--import Language.Haskell.TH.All---#ifdef GUESS--import Data.DeriveGuess+module Data.Derive.Bounded where+{-+import Prelude -example = (,) "Bounded" [d|+example :: Sample -    instance Bounded a => Bounded (DataName a) where-        minBound = head [CtorZero, CtorOne minBound, CtorTwo minBound minBound, CtorTwo' minBound minBound]-        maxBound = head [CtorTwo' maxBound maxBound, CtorTwo maxBound maxBound, CtorOne maxBound, CtorZero]+instance Bounded a => Bounded (Sample a) where+    minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]+    maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First] -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeBounded :: Derivation-makeBounded = derivation bounded' "Bounded"-bounded' dat = [instance_context ["Bounded"] "Bounded" dat [(ValD (VarP (mkName-    "minBound")) (NormalB (AppE (VarE (mkName "head")) (ListE ((map (\(ctorInd,-    ctor) -> (applyWith (ConE (mkName ("" ++ ctorName ctor))) (replicate (-    ctorArity ctor) (VarE (mkName "minBound"))))) (id (zip [0..] (dataCtors dat-    ))))++[])))) []),(ValD (VarP (mkName "maxBound")) (NormalB (AppE (VarE (-    mkName "head")) (ListE ((map (\(ctorInd,ctor) -> (applyWith (ConE (mkName (-    "" ++ ctorName ctor))) (replicate (ctorArity ctor) (VarE (mkName "maxBound"-    ))))) (reverse (zip [0..] (dataCtors dat))))++[])))) [])]]+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 "Nothing" (List []),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 "BDecls" (List+    [List []])])]),App "InsDecl" (List [App "PatBind" (List [App+    "PVar" (List [App "Ident" (List [String "maxBound"])]),App+    "Nothing" (List []),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 "BDecls" (List [List []])])])])+    ]+-- GENERATED STOP

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

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

@@ -0,0 +1,75 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}++module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where++import Data.Derive.DSL.HSE+import Data.Derive.DSL.DSL+import Data.Maybe+import Data.List+import Data.Generics.PlateData+++apply :: DSL -> Input -> Out+apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}+++env = Env+    (error "Env.envInput: uninitialised")+    (error "Env.envCtor: uninitialised")+    (error "Env.envField: uninitialised")+    (error "Env.envFold: uninitialised")+++data Env = Env  {envInput :: Input+                ,envCtor :: Ctor+                ,envField :: Integer+                ,envFold :: (Output,Output) }++applyEnv :: DSL -> Env -> Output+applyEnv dsl env@(Env input ctor field fold) = f dsl+    where+    vars = dataDeclVars input++    f (Instance ctx hd body) =+        OApp "InstDecl"+            [out+                [ClassA (UnQual $ Ident c) [TyVar $ Ident v]+                | let seen = [x | TyVar (Ident x) <- universeBi $ concatMap ctorDeclFields $ dataCtors input]+                , v <- dataDeclVars input `intersect` seen+                , c <- ctx]+            , out $ UnQual $ Ident hd+            , out [TyParen $ foldl TyApp+                (TyCon $ UnQual $ Ident $ dataName input)+                (map tyVar $ dataDeclVars input)]+            , f body]++    f (Application (f -> OList xs)) =+        foldl1 (\a b -> OApp "App" [a,b]) xs++    f (MapCtor dsl) = OList  [  applyEnv dsl env{envCtor=c}+         |  c <- dataCtors input]+    f (MapField dsl) = OList [applyEnv dsl env{envField=i}+         | i <- [1.. fromIntegral $ ctorArity ctor]]++    f DataName = OString $ dataName input+    f CtorName = OString $ ctorName ctor+    f CtorArity = OInt $ ctorArity ctor+    f CtorIndex = OInt $ ctorIndex input ctor+    f FieldIndex = OInt $ field++    f Head = fst fold+    f Tail = snd fold+    f (Fold cons (f -> OList xs)) =+        foldr1 (\a b -> applyEnv cons env{envFold=(a,b)}) xs++    f (List xs) = OList $ map f xs+    f (Reverse (f -> OList xs)) = OList $ reverse xs+    f (Concat (f -> OList [])) = OList []+    f (Concat (f -> OList xs)) = foldr1 g xs+            where  g (OList    x) (OList    y) = OList    (x++y)+                   g (OString  x) (OString  y) = OString  (x++y)+    f (String x) = OString x+    f (Int x) = OInt x+    f (ShowInt (f -> OInt x)) = OString $ show x+    f (App x (f -> OList ys)) = OApp x ys

@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Derive.DSL.DSL where++import Data.Derive.DSL.HSE+import Data.List+import Data.Data+import Data.Generics.PlateData++data DSL = App String DSL{-List-}+         | Concat DSL+         | Reverse DSL+         | String String+         | ShowInt DSL+         | Int Integer+         | List [DSL]+         +         | MapField DSL+         | MapCtor DSL+         | DataName+         | CtorName+         | CtorIndex+         | CtorArity+         | FieldIndex+         +         | Fold DSL DSL+         | Head+         | Tail+         +         | Instance [String] String DSL{-[InstDecl]-}+         | Application DSL{-List-}+           deriving (Data,Typeable,Show)++box x = List [x]+nil = List []+append x y = Concat $ List [x,y]+++fromOut :: Output -> DSL+fromOut (OApp x y) = App x (List $ map fromOut y)+fromOut (OList x) = List (map fromOut x)+fromOut (OString x) = String x+fromOut x = error $ show ("fromOut",x)+++{-+_1 s x1 = App s $ List [x1]+_2 s x1 x2 = App s $ List [x1,x2]+_3 s x1 x2 x3 = App s $ List [x1,x2,x3]+_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]++o x = fromOut $ out x++dslEq :: DSL+dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull+    where+        match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])+        vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))+        bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]+        pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")+        var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)++        dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]+-}+++simplifyDSL :: DSL -> DSL+simplifyDSL = transform f+    where+        f (Concat (List xs)) = case g xs of+            [x] -> x+            [] -> List []+            xs -> Concat $ List xs+        f x = x++        g (List x:List y:zs) = g $ List (x++y):zs+        g (List []:xs) = g xs+        g (String "":xs) = g xs+        g (x:xs) = x : g xs+        g [] = []+++prettyTex :: DSL -> String+prettyTex = f id . transform g+    where+        bracket x = "(" ++ x ++ ")"+    +        f b (App x (List [])) = x+        f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs+        f b (App x y) = b $ x ++ " " ++ f bracket y+        f b (Concat x) = b $ "concat " ++ f bracket x+        f b (Reverse x) = b $ "reverse " ++ f bracket x+        f b (String x) = show x+        f b (ShowInt x) = b $ "showInt " ++ f bracket x+        f b (Int x) = show x+        f b (List []) = "nil"+        f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"+        f b (MapField x) = b $ "mapField " ++ f bracket x+        f b (MapCtor x) = b $ "mapCtor " ++ f bracket x+        f b DataName = "dataName"+        f b CtorName = "ctorName"+        f b CtorIndex = "ctorIndex"+        f b CtorArity = "ctorArity"+        f b FieldIndex = "fieldIndex"+        f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y+        f b Head = "head"+        f b Tail = "tail"+        f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z+        f b (Application x) = b $ "application " ++ f bracket x++        g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y+        g x = x

@@ -0,0 +1,141 @@+{-# LANGUAGE PatternGuards #-}++module Data.Derive.DSL.Derive(derive) where++import Data.Derive.DSL.HSE+import Data.Derive.DSL.DSL+import Data.Derive.DSL.Apply+import Data.List+import Data.Char+import Data.Maybe+++data Guess = Guess DSL+           | GuessFld Int DSL+           | GuessCtr Int Bool DSL  -- 0 based index, does it mention CtorName+             deriving Show+++ctrNames = map ctorName $ dataCtors sample+++derive :: Out -> [DSL]+derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]+++guess :: Output -> [Guess]++guess (OApp "InstDecl" [OList ctxt,name,typ,bod])+    | OApp "UnQual" [OApp "Ident" [OString name]] <- name+    , OList [OApp "TyParen" [OApp "TyApp"+        [OApp "TyCon" [OApp "UnQual" [OApp "Ident" [OString nam]]]+        ,OApp "TyVar" [OApp "Ident" [OString var]]]]] <- typ+    , nam == dataName sample+    , ctxt <- [x | OApp "ClassA" [OApp "UnQual" [OApp "Ident" [OString x]],_] <- ctxt]+    = [Guess $ Instance ctxt name y | Guess y <- guess bod]+++guess (OList xs) = guessList xs+guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)+    +guess (OString x) +    | Just i <- findIndex (`isSuffixOf` x) ctrNames = [GuessCtr i True $ String (take (length x - length (ctrNames !! i)) x) `append` CtorName]+    | "Sample" `isSuffixOf` x = [Guess $ String (take (length x - 6) x) `append` DataName]+    | otherwise =+         [lift (\d -> append (String $ init x) (ShowInt d)) g | x /= "", isDigit (last x), g <- guess $ OInt $ read [last x]] +++         [Guess $ String x]++guess (OInt i) =+    [GuessFld (fromInteger i) FieldIndex | i `elem` [1,2]] +++    [GuessCtr 1 False CtorIndex | i == 1] +++    [GuessCtr 1 False CtorArity | i == 2] +++    [Guess $ Int i]++guess x = error $ show ("fallthrough",x)+++{-+First try and figure out runs to put them in to one possible option+Then try and figure out similarities to give them the same type+-}+guessList :: [Output] -> [Guess]+guessList xs = mapMaybe sames $ map diffs $ sequence $ map guess xs+    where+        -- Given a list of guesses, try and collapse them into one coherent guess+        -- Each input Guess will guess at a List, so compose with Concat+        sames :: [Guess] -> Maybe Guess+        sames xs = do+            let (is,fs) = unzip $ map fromGuess xs+            i <- maxim is+            return $ toGuess i $ Concat $ List fs++        -- Promote each Guess to be a list+        diffs :: [Guess] -> [Guess]++        diffs (GuessCtr 0 True x0:GuessCtr 1 True x1:GuessCtr 2 True x2:xs)+            | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (MapCtor x1) : diffs xs+            where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}+        +        diffs (GuessCtr 2 True x2:GuessCtr 1 True x1:GuessCtr 0 True x0:xs)+            | f 0 x0 == f 0 x1 && f 2 x2 == f 2 x1 = Guess (Reverse $ MapCtor x1) : diffs xs+            where f i x = applyEnv x env{envInput=sample, envCtor=dataCtors sample !! i}+        +        diffs (GuessFld 1 x1:GuessFld 2 x2:xs)+            | f 1 x1 == f 1 x2 = GuessCtr 1 False (MapField x2) : diffs xs+            where f i x = applyEnv x env{envInput=sample, envField=i}+        +        diffs (GuessFld 2 x2:GuessFld 1 x1:xs)+            | f 1 x1 == f 1 x2 = GuessCtr 1 False (Reverse $ MapField x2) : diffs xs+            where f i x = applyEnv x env{envInput=sample, envField=i}++        diffs (x:xs) = lift box x : diffs xs+        diffs [] = []+++gssFold o@(OApp op [x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)+    where+        follow dir (OApp op2 [a,m2,b]) | op == op2 && m == m2 = a2 : follow dir b2+            where (a2,b2) = if dir then (a,b) else (b,a)+        follow dir x = [x]++        f dir xs | length xs <= 2 = []+        f dir xs = map (lift g) $ guess $ OList xs+            where g = Fold (App op $ List [h,fromOut m,t])+                  (h,t) = if dir then (Head,Tail) else (Tail,Head)++gssFold _ = []+++gssApp (OApp "App" [OApp "App" [x,y],z]) = map (lift Application) $ guess $ OList $ fromApp x ++ [y,z]+    where fromApp (OApp "App" [x,y]) = fromApp x ++ [y]+          fromApp x = [x]+gssApp _ = []+    ++lift :: (DSL -> DSL) -> Guess -> Guess+lift f x = toGuess a (f b)+    where (a,b) = fromGuess x+++type GuessState = Maybe (Either Int (Int,Bool))++fromGuess :: Guess -> (GuessState, DSL)+fromGuess (Guess x) = (Nothing, x)+fromGuess (GuessFld i x) = (Just (Left i), x)+fromGuess (GuessCtr i b x) = (Just (Right (i,b)), x)++toGuess :: GuessState -> DSL -> Guess+toGuess Nothing = Guess+toGuess (Just (Left i)) = GuessFld i+toGuess (Just (Right (i,b))) = GuessCtr i b+++-- return the maximum element, if one exists+maxim :: [GuessState] -> Maybe GuessState+maxim [] = Just Nothing+maxim [x] = Just x+maxim (Nothing:xs) = maxim xs+maxim (x:Nothing:xs) = maxim $ x:xs+maxim (x1:x2:xs) | x1 == x2 = maxim $ x1:xs+maxim (Just (Right (i1,b1)):Just (Right (i2,b2)):xs) | i1 == i2 = maxim $ Just (Right (i1,max b1 b2)) : xs+maxim _ = Nothing

@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where++import Language.Haskell hiding (List, App, String, Int)+import qualified Language.Haskell.Exts as H+import Data.Data+import Data.Generics.PlateData+import Data.Maybe+import Data.List+import Data.Function+import Unsafe.Coerce+import Control.Monad.State+++---------------------------------------------------------------------+-- EXAMPLES++{-+-- data List a = Nil | Cons a (List a)+list :: Input+list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]+-}+++-- data Sample a = First | Second a a | Third a+sample :: Input+sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs []+    where+        ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]+        ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ UnBangedTy $ tyVar "a"+++---------------------------------------------------------------------+-- UTILITIES++outEq :: Out -> Out -> Bool+outEq = (==) `on` transformBi (const sl)++---------------------------------------------------------------------++showOut x = unlines $ map prettyPrint x+++type Input = DataDecl+type Ctor = CtorDecl++dataName = dataDeclName+dataVars = length . dataDeclVars+dataCtors = dataDeclCtors+ctorName = ctorDeclName+ctorArity = fromIntegral . ctorDeclArity++ctorIndex :: Input -> Ctor -> Integer+ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat+++toInput :: DataDecl -> Input+toInput x = x+++type Out = [Decl]++++data Output = OString String+            | OInt Integer+            | OApp String [Output]+            | OList [Output]+            | OIgnore+            | OCustom String+              deriving (Eq,Show,Data,Typeable)+++toOutput :: Data a => a -> Output+toOutput x+    | t == typeOf "" = OString $ coerce x+    | c == "[]" = OList $ fList x+    | t == typeOf sl = OIgnore+    | t == typeOf (1 :: Integer) = OInt $ coerce x+    | otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)+    where+        t = typeOf x+        c = show $ fst $ splitTyConApp t++        fList :: Data a => a -> [Output]+        fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]++fromOutput :: Data a => Output -> a+fromOutput (OList xs) = res+    where res = f xs+          f [] = fromConstr $ readCon dat "[]"+          f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"+          dat = dataTypeOf res+          typ = typeOf res+          +          g :: (Data a, Data b) => Output -> a -> b+          g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x++fromOutput (OApp str args) = res+    where dat = dataTypeOf res+          res = evalState (fromConstrM f $ readCon dat str) args+          f :: Data a => State [Output] a+          f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else+                              do x:xs <- get; put xs; return $ fromOutput x++fromOutput (OString x) = coerce x+fromOutput (OInt x) = coerce x+++coerce x = fromMaybe (error "Error in coerce") $ cast x+readCon dat x = fromMaybe (error $ "Error in readCon, " ++ x) $ readConstr dat x+out x = toOutput x+fromState :: State a x -> x+fromState = undefined

@@ -0,0 +1,114 @@+{-# LANGUAGE RelaxedPolyRec, RankNTypes, ScopedTypeVariables #-}+{- OPTIONS_GHC -fglasgow-exts -}++module Data.Derive.DSL.SYB(dslSYB) where++import Data.Derive.DSL.HSE+import qualified Language.Haskell.Exts as H+import Data.Derive.DSL.DSL+import Control.Monad+import Control.Monad.State hiding (lift)+import Data.Generics+import Data.Maybe+++dslSYB :: DSL -> Maybe Out+dslSYB = syb+++syb :: Data a => DSL -> Maybe a+syb = dsimple & dlistAny & dapp -- & derr++lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)+lift f = maybe Nothing id . cast . f++(&) a b x = a x `mplus` b x+++dlistAny :: forall a . Data a => DSL -> Maybe a+dlistAny x | isNothing con = Nothing+           | otherwise = res +    where+        con = readConstr dat "(:)"+        val = fromConstr (fromJust con) :: a+        +        dat = dataTypeOf (undefined :: a)+        +        res = gmapQi 0 f val++        f :: Data d => d -> Maybe a+        f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]+++dlist :: Data a => DSL -> Maybe [a]+dlist x = do+    List xs <- return x+    mapM syb xs+++dapp :: forall a . Data a => DSL -> Maybe a+dapp x = do+    App name (List args) <- return x+    let dat = dataTypeOf (undefined :: a)+        (res,s) = runState (fromConstrM f $ readCon dat name) (True,args)+    if fst s then Just res else Nothing+    where+        f :: forall b . Data b => State (Bool,[DSL]) b+        f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl+            else do+                (b,x:xs) <- get+                case syb x of+                    Nothing -> do put (False,xs) ; return undefined+                    Just y -> do put (b,xs) ; return y+++derr :: Data a => DSL -> Maybe a+derr x = error $ "Couldn't dslSYB on: " ++ show x+++dsimple :: Data a => DSL -> Maybe a+dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle+++dinstance :: DSL -> Maybe Decl+dinstance x = do+    Instance _ name bod <- return x+    bod <- syb bod+    return $ InstDecl sl+        [ClassA (UnQual $ Ident "Data") [TyVar $ Ident "d_type"]]+        (UnQual $ Ident name) [TyVar $ Ident "d_type"]+        bod+++dstring :: DSL -> Maybe String+dstring x = do+    String x <- return x+    return x+++dmapctor :: DSL -> Maybe Exp+dmapctor x = do+    App "List" (List [MapCtor x]) <- return x+    x <- syb x+    return $ ListComp x [QualStmt $ Generator sl (PVar $ Ident "d_ctor")+        (H.App (v "d_dataCtors") (Paren $ ExpTypeSig sl (v "undefined") (TyVar $ Ident "d_type")))]+++dsingle :: DSL -> Maybe Exp+dsingle (App "Lit" (List [App "Int" (List [CtorArity])])) = Just $ Paren $ H.App (v "d_ctorArity") (v "d_ctor")+dsingle (App "Lit" (List [App "Int" (List [CtorIndex])])) = Just $ Paren $ H.App (v "d_ctorIndex") (v "d_ctor")+dsingle (App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),List []])) = Just $ Paren $+    ExpTypeSig sl (H.App (v "d_ctorValue") (v "d_ctor")) (TyVar $ Ident "d_type")+dsingle _ = Nothing+++dapplication :: DSL -> Maybe Exp+dapplication x = do+    Application (List xs) <- return x+    syb $ f xs+    where+        f (x:y:z) = f (App "App" (List [x,y]) : z)+        f [x] = x+++v = Var . UnQual . Ident

@@ -1,100 +1,139 @@-{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}+module Data.Derive.Data where+{-+import Data.Data --- | Derivation for the 'Data.Generics.Basics.Data' class, as--- described in the Scrap Your Boilerplate paper.  No type structure--- is abstracted+example :: Custom -module Data.Derive.Data(makeData) where+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 -import Language.Haskell.TH.All+    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 +    toConstr x@First{}  = indexConstr (dataTypeOf x) (0+1)+    toConstr x@Second{} = indexConstr (dataTypeOf x) (1+1)+    toConstr x@Third{}  = indexConstr (dataTypeOf x) (2+1) -#ifdef GUESS+    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)] -import Data.Generics-import Data.DeriveGuess+test :: Computer -instance Typeable (DataName a) where+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+    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] -example = (,) "Data" [d|+-} -    instance (Data a, Typeable a) => Data (DataName a) where-        gfoldl k r CtorZero = r CtorZero-        gfoldl k r (CtorOne x1) = r CtorOne `k` x1-        gfoldl k r (CtorTwo x1 x2) = r CtorTwo `k` x1 `k` x2-        gfoldl k r (CtorTwo' x1 x2) = r CtorTwo' `k` x1 `k` x2-    |]+import Data.Derive.DSL.HSE+import qualified Language.Haskell as H -#endif+-- GENERATED START -{- GHC autogenerated instance:-instance (Data a, Data b) => Data (T a b) where-     gfoldl k z (C1 a b) = z C1 `k` a `k` b-     gfoldl k z C2       = z C2+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation -     gunfold k z c = case constrIndex c of-                         1 -> k (k (z C1))-                         2 -> z C2+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 "BDecls" (List [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])])]),MapCtor (App "Alt" (List [App "PLit" (+    List [App "Int" (List [CtorIndex])]),App "UnGuardedAlt" (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 "BDecls" (List [List []])]))])]),App+    "BDecls" (List [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 "BDecls" (List [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 "BDecls" (List [List [App "PatBind" (List [App "PVar" (List [+    App "Ident" (List [String "ty"])]),App "Nothing" (List []),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 "BDecls" (List [List []])])]])])]+    ])])])]+-- GENERATED STOP -     toConstr (C1 _ _) = con_C1-     toConstr C2       = con_C2 -     dataTypeOf _ = ty_T-- con_C1 = mkConstr ty_T "C1" [] Prefix- con_C2 = mkConstr ty_T "C2" [] Prefix- ty_T   = mkDataType "Module.T" [con_C1, con_C2]--}+custom d = customContext context d . customSplice splice d -makeData :: Derivation-makeData = derivation genDataInst "Data"+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 -genDataInst :: DataDef -> [Dec]-genDataInst dat = [-      instance_context ["Data","Typeable"] "Data" dat -      [ FunD (mkName "gfoldl") (gfoldlDefs dat),-        FunD (mkName "gunfold") (gunfoldDefs dat),-        FunD (mkName "toConstr") (toConstrDefs dat),-        FunD (mkName "dataTypeOf") (dataTypeOfDefs dat) ]-    ]-toConstrDefs :: DataDef -> [Clause]-toConstrDefs dat = map toConstrImpl (zip [(1::Integer)..] (dataCtors dat)) where-    toConstrImpl (ctorInd,ctor) = Clause [toConstrParams ctor] (toConstrDef ctorInd ctor) []-    toConstrParams ctor = AsP (mkName "ctor") (matchConstructor ctor)-    toConstrDef ind _ctor = NormalB $ -        app (varExpr "indexConstr")-            [ AppE  (varExpr "dataTypeOf") (varExpr "ctor"), lit ind ]-dataTypeOfDefs :: DataDef -> [Clause]-dataTypeOfDefs dat = [Clause dtOfParams dtOfDef dtOfClauses] where-    dtOfParams = [WildP]-    dtOfDef = NormalB $ varExpr "ty_T"-    dtOfClauses = (mkDt (dataCtors dat)) : map mkCon (zip [(1::Integer)..] (dataCtors dat))-    mkCon (ix,ctor) = FunD (mkName $ "con_C"++show ix) [Clause [] (NormalB (mkConImpl ix ctor)) []] -    mkConImpl _ix ctor = app (varExpr "mkConstr") -        [varExpr "ty_T", lit (ctorName ctor), ListE (fields ctor), ConE (mkName "Prefix") ]-    fields = map lit . ctorFields-    mkDt ctors = FunD (mkName "ty_T") [Clause [] (NormalB (mkDtImpl ctors)) []]-    mkDtImpl ctors = app (varExpr "mkDataType") [lit (show$ qualifiedDataName dat) , mkConVars ctors]-    mkConVars ctors = ListE $ map (\ix -> varExpr ("con_C"++show ix)) [(1::Int)..(length ctors)]-gfoldlDefs :: DataDef -> [Clause]-gfoldlDefs dat = map gfoldlImpl (zip [(1::Integer)..] (dataCtors dat)) where-    gfoldlImpl (_ctorInd,ctor) = Clause (gfoldlParams ctor) (gfoldlDef ctor) []-    gfoldlParams ctor = [ VarP (mkName "k"), VarP (mkName "r"), matchConstructor ctor ]-    gfoldlDef ctor = NormalB $ foldr1With (varExpr "k") foldFields where-        foldFields =    map (\field -> (varExpr ("x" ++ show field))) (reverse [1..ctorArity ctor])-                     ++ [ (AppE (varExpr "r") (ConE (mkName (ctorName ctor)))) ]-gunfoldDefs :: DataDef -> [Clause]-gunfoldDefs dat = [Clause guParams (NormalB guDef) []] where-    guParams = map (VarP . mkName) ["k","z","c"]-    guDef     = CaseE (AppE (varExpr "constrIndex") (varExpr "c")) $-                  map (guCase) (zip [(1::Integer)..] (dataCtors dat))-    guCase (ix,ctor) = Match (LitP (IntegerL ix)) (NormalB$ guCaseBody ctor) []-    guCaseBody ctor = foldr (\_ e -> AppE (varExpr "k") e)-                           (AppE (varExpr "z") (ConE . mkName . ctorName $ ctor))-                           [1..ctorArity ctor]-varExpr :: String -> Exp-varExpr = VarE . mkName-matchConstructor :: CtorDef -> Pat-matchConstructor ctor = ConP (mkName (ctorName ctor)) (fields++[]) where-    fields = map (\field -> (VarP (mkName ("x" ++ show field))))-                 (id [1..ctorArity ctor])+context :: FullDataDecl -> Context+context d = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]

@@ -0,0 +1,33 @@+module Data.Derive.Default where+{-+import "derive" Data.Derive.Class.Default++example :: Sample++instance Default a => Default (Sample a) where+    def = head [First, Second (const def 1) (const def 2), Third (const def 1)]++-}++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeDefault :: Derivation+makeDefault = derivationDSL "Default" dslDefault++dslDefault =+    List [Instance ["Default"] "Default" (List [App "InsDecl" (List [+    App "PatBind" (List [App "PVar" (List [App "Ident" (List [String+    "def"])]),App "Nothing" (List []),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 "BDecls" (List [+    List []])])])])]+-- GENERATED STOP

@@ -1,46 +1,52 @@-{-# OPTIONS_GHC -fth -cpp #-}---- | Derivation for 'Enum', as defined by the Haskell 98 Language--- report, except that we support arbitrary types.  toEnum (and--- derived functions, notably succ and pred) use undefined to fill all--- fields of nonzero arity constructors.-module Data.Derive.Enum(makeEnum) where--import Language.Haskell.TH.All---#ifdef GUESS+module Data.Derive.Enum where+{-+import Prelude -import Data.DeriveGuess+example :: Sample -example = (,) "Enum" [d|+instance Enum (Sample a) where+    toEnum 0 = First{}+    toEnum 1 = Second{}+    toEnum 2 = Third{}+    toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "Sample" -    instance Enum (DataName a) where-        toEnum 0 = CtorZero{}-        toEnum 1 = CtorOne {}-        toEnum 2 = CtorTwo {}-        toEnum 3 = CtorTwo'{}-        toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "DataName"-        -        fromEnum (CtorZero{}) = 0-        fromEnum (CtorOne {}) = 1-        fromEnum (CtorTwo {}) = 2-        fromEnum (CtorTwo'{}) = 3+    fromEnum (First{}) = 0+    fromEnum (Second{}) = 1+    fromEnum (Third{}) = 2 -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeEnum :: Derivation-makeEnum = derivation enum' "Enum"-enum' dat = [instance_context [] "Enum" dat [FunD (mkName "toEnum") ((map (\(-    ctorInd,ctor) -> (Clause [(LitP (IntegerL ctorInd))] (NormalB ((flip-    RecConE []) (mkName (ctorName ctor)))) [])) (id (zip [0..] (dataCtors dat))-    ))++[(Clause [(VarP (mkName "n"))] (NormalB (applyWith (VarE (mkName "$"))-    [(VarE (mkName "error")),(applyWith (VarE (mkName "++")) [(LitE (StringL-    "toEnum ")),(applyWith (VarE (mkName "++")) [(AppE (VarE (mkName "show")) (-    VarE (mkName "n"))),(applyWith (VarE (mkName "++")) [(LitE (StringL-    ", not defined for ")),(LitE (StringL (dataName dat)))])])])])) [])]++[]),-    FunD (mkName "fromEnum") ((map (\(ctorInd,ctor) -> (Clause [((flip RecP [])-    (mkName (ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd))) [])) (id (-    zip [0..] (dataCtors dat))))++[])]]+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 "Int" (List [+    CtorIndex])])],App "Nothing" (List []),App "UnGuardedRhs" (List [+    App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [+    CtorName])]),List []])]),App "BDecls" (List [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 "BDecls" (+    List [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 "BDecls" (List [List []])]))])])])]+-- GENERATED STOP

@@ -1,66 +1,104 @@-{-# OPTIONS_GHC -fth -cpp #-}+module Data.Derive.EnumCyclic where+{-+import Prelude(Enum) --- | @EnumCyclic@ defines the @Enum@ class, using the same--- modifications as our @Enum@ derivation, but additionally @succ@--- and @pred@ treat the data type as cyclic, wrapping between the--- first and last constructors.+example :: Sample -module Data.Derive.EnumCyclic(makeEnumCyclic) where+instance Enum (Sample a) where+    toEnum 0 = First{}+    toEnum 1 = Second{}+    toEnum 2 = Third{}+    toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample" -import Language.Haskell.TH.All+    fromEnum (First{}) = 0+    fromEnum (Second{}) = 1+    fromEnum (Third{}) = 2  -#ifdef GUESS--import Data.DeriveGuess--example = (,) "EnumCyclic" [d|--    instance Enum (DataName a) where-        toEnum 0 = CtorZero{}-        toEnum 1 = CtorOne {}-        toEnum 2 = CtorTwo {}-        toEnum 3 = CtorTwo'{}-        toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "DataName"-        -        fromEnum (CtorZero{}) = 0-        fromEnum (CtorOne {}) = 1-        fromEnum (CtorTwo {}) = 2-        fromEnum (CtorTwo'{}) = 3-        -        -        succ a = if b == 3 then toEnum 0 else toEnum (b+1)-            where b = fromEnum a+    succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)+        where b = fromEnum a -        pred a = if b == 0 then toEnum 3 else toEnum (b-1)-            where b = fromEnum a+    pred a = if b == 0 then toEnum length [First{},Second{},Third{}] else toEnum (b-1)+        where b = fromEnum a -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeEnumCyclic :: Derivation-makeEnumCyclic = derivation enumCyclic' "EnumCyclic"-enumCyclic' dat = [instance_context [] "Enum" dat [(FunD (mkName "toEnum") ((-    map (\(ctorInd,ctor) -> (Clause [(LitP (IntegerL ctorInd))] (NormalB ((flip-    RecConE []) (mkName ("" ++ ctorName ctor)))) [])) (id (zip [0..] (dataCtors-    dat))))++[(Clause [(VarP (mkName "n"))] (NormalB (applyWith (VarE (mkName-    "$")) [(VarE (mkName "error")),(applyWith (VarE (mkName "++")) [(LitE (-    StringL "toEnum ")),(applyWith (VarE (mkName "++")) [(AppE (VarE (mkName-    "show")) (VarE (mkName "n"))),(applyWith (VarE (mkName "++")) [(LitE (-    StringL ", not defined for ")),(LitE (StringL (dataName dat)))])])])])) [])-    ]++[])),(FunD (mkName "fromEnum") ((map (\(ctorInd,ctor) -> (Clause [((flip-    RecP []) (mkName ("" ++ ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd)-    )) [])) (id (zip [0..] (dataCtors dat))))++[])),(FunD (mkName "succ") [(-    Clause [(VarP (mkName "a"))] (NormalB (CondE (applyWith (VarE (mkName "==")-    ) [(VarE (mkName "b")),(LitE (IntegerL (toInteger (length (dataCtors dat)))-    ))]) (AppE (VarE (mkName "toEnum")) (LitE (IntegerL 0))) (AppE (VarE (-    mkName "toEnum")) (applyWith (VarE (mkName "+")) [(VarE (mkName "b")),(LitE-    (IntegerL 1))])))) [(ValD (VarP (mkName "b")) (NormalB (AppE (VarE (mkName-    "fromEnum")) (VarE (mkName "a")))) [])])]),(FunD (mkName "pred") [(Clause [-    (VarP (mkName "a"))] (NormalB (CondE (applyWith (VarE (mkName "==")) [(VarE-    (mkName "b")),(LitE (IntegerL 0))]) (AppE (VarE (mkName "toEnum")) (LitE (-    IntegerL (toInteger (length (dataCtors dat)))))) (AppE (VarE (mkName-    "toEnum")) (applyWith (VarE (mkName "-")) [(VarE (mkName "b")),(LitE (-    IntegerL 1))])))) [(ValD (VarP (mkName "b")) (NormalB (AppE (VarE (mkName-    "fromEnum")) (VarE (mkName "a")))) [])])])]]+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 "Int" (List [+    CtorIndex])])],App "Nothing" (List []),App "UnGuardedRhs" (List [+    App "RecConstr" (List [App "UnQual" (List [App "Ident" (List [+    CtorName])]),List []])]),App "BDecls" (List [List []])])),List [+    App "Match" (List [App "Ident" (List [String "toEnum"]),List [App+    "PVar" (List [App "Ident" (List [String "n"])])],App "Nothing" (+    List []),App "UnGuardedRhs" (List [App "InfixApp" (List [App "Var"+    (List [App "UnQual" (List [App "Ident" (List [String "error"])])])+    ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [+    String "$"])])]),Fold (App "InfixApp" (List [Head,App "QVarOp" (+    List [App "UnQual" (List [App "Symbol" (List [String "++"])])]),+    Tail])) (List [App "Lit" (List [App "String" (List [String+    "toEnum "])]),App "App" (List [App "Var" (List [App "UnQual" (List+    [App "Ident" (List [String "show"])])]),App "Var" (List [App+    "UnQual" (List [App "Ident" (List [String "n"])])])]),App "Lit" (+    List [App "String" (List [Concat (List [String+    ", not defined for ",DataName])])])])])]),App "BDecls" (List [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 "BDecls" (List [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 "BDecls" (+    List [List [App "PatBind" (List [App "PVar" (List [App "Ident" (+    List [String "b"])]),App "Nothing" (List []),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+    "BDecls" (List [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])])]),Application (List [App "Var" (+    List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])])+    ,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 "BDecls" (List [List [App "PatBind" (List+    [App "PVar" (List [App "Ident" (List [String "b"])]),App "Nothing"+    (List []),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 "BDecls" (List [List []])])]])])]])])])]+-- GENERATED STOP

@@ -1,51 +1,60 @@-{-# OPTIONS_GHC -fth -cpp #-}---- | Derive 'Eq', as specified in the Haskell 98 Language Report.-module Data.Derive.Eq(makeEq) where--import Control.Monad(guard)--import Language.Haskell.TH.All-+module Data.Derive.Eq where+{-+import Prelude -#ifdef GUESS+example :: Sample -import Data.DeriveGuess+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 -example = (,) "Eq" [d|+test :: Assoced+instance Eq typ => Eq (Assoced typ) where+    Assoced x1 x2 == Assoced y1 y2 = x1 == y1 && x2 == y2 -    instance Eq a => Eq (DataName a) where-        CtorZero == CtorZero = True-        (CtorOne x1) == (CtorOne y1) = x1 == y1 && True-        (CtorTwo x1 x2) == (CtorTwo y1 y2) = x1 == y1 && x2 == y2 && True-        (CtorTwo' x1 x2) == (CtorTwo' y1 y2) = x1 == y1 && x2 == y2 && True-        _ == _ = False+test :: TwoParam+instance Eq b => Eq (TwoParam a b) where+    TwoParam x1 == TwoParam y1 = x1 == y1 -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeEq :: Derivation-makeEq = derivation eq' "Eq"-eq' dat = [instance_context ["Eq"] "Eq" dat [FunD (mkName "==") ((map (\(_-    ,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (-    mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[])),(ConP (mkName-    (ctorName ctor)) ((map (\field -> (VarP (mkName ("y" ++ show field)))) (id-    [1..ctorArity ctor]))++[]))] (NormalB (foldl1With (VarE (mkName "&&")) ((-    map (\field -> (AppE (AppE (VarE (mkName "==")) (VarE (mkName ("x" ++ show-    field)))) (VarE (mkName ("y" ++ show field))))) (id [1..ctorArity ctor]))++-    [(ConE (mkName "True"))]++[]))) [])) (id (zip [0..] (dataCtors dat))))++-    (guard (length (dataCtors dat) > 1) >> [(-    Clause [WildP,WildP] (NormalB (ConE (mkName "False"))) [])]-    )++[])]]--{---- HAND WRITTEN VERSION--eq' dat = simple_instance "Eq" dat [funN "==" body]-    where-        body = map rule (dataCtors dat) ++ [defclause 2 false]+makeEq = derivationDSL "Eq" dslEq -rule ctor = sclause [ctp ctor 'a', ctp ctor 'b']-                    (and_ (zipWith (==:) (ctv ctor 'a') (ctv ctor 'b')))--}+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 "BDecls" (List [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+    "BDecls" (List [List []])])]])])])])]+-- GENERATED STOP

@@ -0,0 +1,66 @@+-- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>++{-|+    A pseudo derivation.  Derive a (non-recursive) fold function for +    the type which takes one function per alternative constructor.  Each+    function takes the same arguments as the constructor and returns+    a value.  When applied to a value the fold function applies the+    function for the matching constructor to the constructor fields.+    This provides a first-class alternative to pattern matching to+    deconstruct the data type.+-}+module Data.Derive.Fold(makeFold) where+{-+test :: Computer++foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a+foldComputer f1 f2 (Laptop x1 x2) = f1 x1 x2+foldComputer f1 f2 (Desktop x1) = f2 x1++test :: Assoced++foldAssoced :: (typ -> String -> a) -> Assoced typ -> a+foldAssoced f1 (Assoced x1 x2) = f1 x1 x2++test :: Either++foldEither :: (a -> c) -> (b -> c) -> Either a b -> c+foldEither f1 f2 (Left x1) = f1 x1+foldEither f1 f2 (Right x1) = f2 x1++test :: Bool++foldBool :: a -> a -> Bool -> a+foldBool f1 f2 False = f1+foldBool f1 f2 True = f2++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+import Data.Generics.PlateData+++makeFold :: Derivation+makeFold = Derivation "Fold" $ \(_,d) -> Right $ simplify $ mkFold d+++mkFold :: DataDecl -> [Decl]+mkFold d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f funs $ dataDeclCtors d]+    where+        n = "fold" ++ title (dataDeclName d)+        funs = ['f' : show i | i <- [1..length (dataDeclCtors d)]]+        f fun c = Match sl (name n) pat Nothing (UnGuardedRhs bod) (BDecls [])+            where pat = map pVar funs ++ [PParen $ PApp (qname $ ctorDeclName c) (map pVar vars)]+                  bod = apps (var fun) (map var vars)+                  vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]+++foldType :: DataDecl -> Type+foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]+    where+        dt = dataDeclType d+        v = head $ map (tyVar . return) ['a'..] \\ universe dt+        f c = TyParen $ tyFun $ map (fromBangType . snd) (ctorDeclFields c) ++ [v]+

@@ -1,6 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}-- {-     This module is not written/maintained by the usual Data.Derive author. @@ -11,16 +8,35 @@     and CC Twan. -} --- NOTE: Cannot be guessed as it relies on type information- module Data.Derive.Foldable(makeFoldable, makeFoldableN) where -import qualified Data.Foldable ( foldr )+{-+import Data.Foldable(Foldable)+import qualified Data.Foldable(foldr) -import Language.Haskell.TH.All-import Data.DeriveTraversal+test :: FailList+instance Foldable (FailList t1) where+    foldr _f b Zero = b+    foldr _f b (Fail a1) = b+    foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2) +test :: Sample+instance Foldable Sample where+    foldr _f 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 _f b (Left a1) = 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 @@ -28,11 +44,12 @@ makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable"  foldrTraversal = defaultTraversalType-        { traversalName   = 'Data.Foldable.foldr-        , traversalFunc   = \n a -> l1 "flip" (l1 n a)+        { 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     = l1 "flip" (l0 "const")-        , traverseTuple   =         foldr (.:) id'-        , traverseCtor    = const $ foldr (.:) id'-        , traverseFunc    = \pat rhs -> sclause [vr "_f", vr "b", pat] (AppE rhs (vr "b"))+        , 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")) (BDecls [])         }+    where a .: b = InfixApp (paren a) (qvop ".") (paren b)

@@ -1,36 +1,58 @@-{-# OPTIONS_GHC -fth -cpp #-}+{-|+    A pseudo derivation.  For each constructor in the data type,+    deriving @From@ generates @from@/CtorName/ which extracts the+    components if given the appropriate constructor, and crashes+    otherwise.  Unlike the DrIFT @\"From\"@ derivation, our version+    works for all constructors - zero-arity constructors always return+    @()@, arity-one constructors return the contained value, and all+    others return a tuple with all the components.+-} --- | A pseudo derivation.  For each constructor in the data type,--- deriving @From@ generates @from@/CtorName/ which extracts the--- components if given the appropriate constructor, and crashes--- otherwise.  Unlike the DrIFT @\"From\"@ derivation, our version--- works for all constructors - zero-arity constructors always return--- @()@, arity-one constructors return the contained value, and all--- others return a tuple with all the components. module Data.Derive.From(makeFrom) where -import Language.Haskell.TH.All+{- +test :: Sample -#ifdef GUESS+fromFirst :: Sample a -> ()+fromFirst First = () -import Data.DeriveGuess+fromSecond :: Sample a -> (a, a)+fromSecond (Second x1 x2) = (x1,x2) -example = (,) "From" [d|+fromThird :: Sample a -> a+fromThird (Third x1) = x1 -    fromCtorZero (CtorZero) = ()-    fromCtorOne  (CtorOne x1) = tup1 x1-    fromCtorTwo  (CtorTwo x1 x2) = (x1,x2)-    fromCtorTwo' (CtorTwo' x1 x2) = (x1,x2)+-} -    |]+import Language.Haskell+import Data.Derive.Internal.Derivation -#endif  makeFrom :: Derivation-makeFrom = derivation from' "From"-from' dat = ((map (\(ctorInd,ctor) -> (FunD (mkName ("from" ++ ctorName ctor))-    [(Clause [(ConP (mkName ("" ++ ctorName ctor)) ((map (\field -> (VarP (-    mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (-    TupE ((map (\field -> (VarE (mkName ("x" ++ show field)))) (id [1..-    ctorArity ctor]))++[]))) [])])) (id (zip [0..] (dataCtors dat))))++[])+makeFrom = Derivation "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d+++makeFromCtor :: DataDecl -> CtorDecl -> [Decl]+makeFromCtor d c = [TypeSig sl [name from] typ, FunBind [match]]+    where+        n = ctorDeclName c+        from = "from" ++ n++        typ = TyFun (dataDeclType d)+            (tyTuple $ map (fromBangType . snd) $ ctorDeclFields c)++        match = Match sl (name from) [pat] Nothing (UnGuardedRhs rhs) (BDecls [])+        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+++tyTuple [] = TyCon $ Special UnitCon+tyTuple [x] = x+tyTuple xs = TyTuple Boxed xs+++valTuple [] = Con $ Special UnitCon+valTuple [x] = x+valTuple xs = Tuple xs

@@ -14,10 +14,32 @@ -- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>. module Data.Derive.Functor(makeFunctor,makeFunctorN) where -import Language.Haskell.TH.All-import Data.DeriveTraversal+{-+import Prelude +test :: FailList+instance Functor (FailList t1) where+    fmap _f Zero = Zero+    fmap _f (Fail a1) = Fail 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 _f 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 @@ -25,15 +47,16 @@ makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor"  functorTraversal = defaultTraversalType-        { traversalName   = "fmap"-        , traverseArrow   = functorForArrowType-        , traverseFunc    = \pat rhs -> sclause [vr "_f", pat] rhs+        { traversalName   = qname "fmap"+        , traverseArrow   = Just functorForArrowType+        , traverseFunc    = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) (BDecls [])         }  functorForArrowType :: Exp -> Exp -> Exp functorForArrowType a b-  | isId a && isId b  =  id'-  | isId a            =  InfixE (Just b) (l0 ".") Nothing-  | isId b            =  InfixE Nothing  (l0 ".") (Just a)-  | otherwise         =  LamE [l0 "arg"] $ b .: l0 "arg" .: a- where isId = (id'==)+  | isId a && isId b  =  var "id"+  | isId a            =  LeftSection b (qvop ".")+  | isId b            =  RightSection (qvop ".") a+  | otherwise         =  Lambda sl [pVar "arg"] $ b .: var "arg" .: a+ where isId = (var "id" ==)+       a .: b = InfixApp (paren a) (qvop ".") (paren b)

@@ -1,41 +1,40 @@---- | Has is a pseudo derivation.  For each field of any constructor of--- the data type, Has generates @has@/FieldName/ which returns 'True'--- if given the the given field is a member of the constructor of the--- passed object, and 'False' otherwise.+{-|+    Has is a pseudo derivation.  For each field of any constructor of+    the data type, Has generates @has@/FieldName/ which returns 'True'+    if given the the given field is a member of the constructor of the+    passed object, and 'False' otherwise.+-} module Data.Derive.Has(makeHas) where -import Language.Haskell.TH.All-import Data.Char-import Data.List- {--data Computer = Laptop {weight :: Int, memory :: Int}-              | Desktop {memory :: Int, processor :: Int}+test :: Computer -==>+hasSpeed :: Computer -> Bool+hasSpeed _ = True -hasWeight (Laptop{}) = True+hasWeight :: Computer -> Bool+hasWeight Laptop{} = True hasWeight _ = False -hasMemory (Laptop{}) = True-hasMemory (Desktop{}) = True+test :: Sample+-} -hasProcessor (Desktop{}) = True-hasProcessor _ = False+import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List --}  makeHas :: Derivation-makeHas = derivation has' "Has"+makeHas = Derivation "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d -has' dat = map f fields++makeHasField :: DataDecl -> String -> [Decl]+makeHasField d field = [TypeSig sl [name has] typ, binds has ms]     where-        ctors = dataCtors dat-        fields = nub $ concatMap ctorFields ctors-        -        f field = funN ("has" ++ toUpper (head field) : tail field) $-                       [sclause [RecP (mkName $ ctorName c) []] true | (True,c) <- zip matches ctors] ++-                       [sclause [WildP] false | not $ and matches]-            where-                matches = map (\c -> field `elem` ctorFields c) ctors+        has = "has" ++ title field+        typ = TyFun (dataDeclType d) (tyCon "Bool")+        (yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d+        match pat val = ([pat], con val)++        ms | null no = [match PWildCard "True"]+           | otherwise = [match (PRec (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match PWildCard "False"]

@@ -0,0 +1,15 @@+-- GENERATED START+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}++module Data.Derive.Instance.Arities where++import Data.Derive.Class.Arities+import Data.Derive.Internal.Instance++ +instance (Data d_type) => Arities d_type where+        arities _+          = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |+             d_ctor <- d_dataCtors (undefined :: d_type)]++-- GENERATED STOP

@@ -0,0 +1,41 @@++module Data.Derive.Internal.Derivation(+    Derivation(..), derivationDSL, derivationCustomDSL,+    customSplice, customContext+    ) where++import Data.DeriveDSL+import Data.Derive.DSL.HSE+import Data.Generics.PlateData+++data Derivation = Derivation+    {derivationName :: String+    ,derivationOp :: FullDataDecl -> Either String [Decl]+    }+++derivationDSL :: String -> DSL -> Derivation+derivationDSL name dsl = Derivation name $ applyDSL dsl . snd+++derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation+derivationCustomDSL name custom dsl = Derivation name $+    \d -> case applyDSL dsl $ snd d of+              Left x -> Left x+              Right x -> Right $ custom d x+++customSplice :: (FullDataDecl -> Exp -> Exp) -> (FullDataDecl -> [Decl] -> [Decl])+customSplice custom d = transformBi f+    where+        f (SpliceExp (ParenSplice x)) = custom d x+        f x = x+++customContext :: (FullDataDecl -> Context) -> (FullDataDecl -> [Decl] -> [Decl])+customContext custom d = map f+    where+        ctx = custom d+        f (InstDecl sl _ a b c) = InstDecl sl  ctx a b c+        f x = x

@@ -0,0 +1,35 @@+{-# LANGUAGE ExistentialQuantification #-}++module Data.Derive.Internal.Instance(+    Data, d_ctorArity, d_ctorValue, d_dataCtors+    ) where++import Data.Data+import Control.Monad+import Control.Monad.State+++data Ctor = Ctor+    {ctorType :: Box+    ,ctorIndex :: Int+    ,ctorRep :: Constr}+++data Box = forall a . Data a => Box a+++d_ctorArity :: Ctor -> Int+d_ctorArity Ctor{ctorType=Box t, ctorRep=rep} = flip execState 0 $+    liftM (`asTypeOf` t) $+    fromConstrM (modify (+1) >> return undefined) rep+++d_ctorValue :: Data a => Ctor -> a+d_ctorValue = error "TODO: d_ctorValue"+++d_dataCtors :: Data a => a -> [Ctor]+d_dataCtors x+    | not $ isAlgType t = error "d_dataCtors only works on algebraic data types"+    | otherwise = zipWith (Ctor $ Box x) [0..] $ dataTypeConstrs t+    where t = dataTypeOf x

@@ -0,0 +1,216 @@+{-+    This module is not written/maintained by the usual Data.Derive author.++    MAINTAINER: Twan van Laarhoven +    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"++    Please send all patches to this module to Neil (ndmitchell -at- gmail),+    and CC Twan.+-}++-- NOTE: Cannot be guessed as it relies on type information++-- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:+-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
+module Data.Derive.Internal.Traversal(+        TraveralType(..), defaultTraversalType,+        traversalDerivation1,+        traversalInstance, traversalInstance1,+        deriveTraversal+    ) where++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+import qualified Data.Set as S+import Control.Monad.Writer+import Control.Applicative+import Data.Generics.PlateData+import Data.Maybe++---------------------------------------------------------------------------------+-- Stuff that should be in a library
++instance Monoid w => Applicative (Writer w) where+      pure = return+      (<*>) = ap++---------------------------------------------------------------------------------
+-- Information datatype, public interface
+
+-- | An expression representing a traversal of a subpart of the data
+type Trav = Exp
+
+-- | What kind of traversal are we deriving?
+data TraveralType = TraveralType
+        { traversalArg    :: Int                     -- ^ On what position are we traversing?
+        , traversalCo     :: Bool                    -- ^ covariant?
+        , traversalName   :: QName                   -- ^ name of the traversal function
+        , traversalId     :: Trav                    -- ^ Identity traversal
+        , traversalDirect :: Trav                    -- ^ Traversal of 'a'
+        , traversalFunc   :: QName -> Trav -> Trav  -- ^ Apply the sub-traversal function
+        , traversalPlus   :: Trav -> Trav -> Trav    -- ^ Apply two non-identity traversals in sequence
+        , traverseArrow   :: Maybe (Trav -> Trav -> Trav)    -- ^ Traverse a function type
+        , traverseTuple   :: [Exp] -> Exp            -- ^ Construct a tuple from applied traversals
+        , traverseCtor    :: String -> [Exp] -> Exp  -- ^ Construct a data type from applied traversals
+        , traverseFunc    :: Pat -> Exp -> Match     -- ^ Construct a clause of the traversal function
+        }
++defaultTraversalType = TraveralType+        { traversalArg    = 1+        , traversalCo     = False+        , traversalName   = undefined -- prevent warnings+        , traversalId     = var "id"+        , traversalDirect = var "_f"+        , traversalFunc   = \x y -> appP (Var x) y+        , traversalPlus   = \x y -> apps (Con $ Special Cons) [paren x, paren y]+        , traverseArrow   = Nothing+        , traverseTuple   = Tuple+        , traverseCtor    = \x y -> apps (con x) (map paren y)+        , traverseFunc    = undefined+        }++data RequiredInstance = RequiredInstance+        { requiredDataArg  :: String -- ^ What argument of the current data type?+        , requiredPosition :: Int    -- ^ What argument position of that type?+        }+      deriving (Eq, Ord)++-- | Monad that collects required instances+type WithInstances a = Writer (S.Set RequiredInstance) a+++vars f c n = [f $ c : show i | i <- [1..n]]+++---------------------------------------------------------------------------------+-- Deriving traversals
+++-- | Derivation for a Traversable like class with just 1 method+traversalDerivation1 :: TraveralType -> String -> Derivation+traversalDerivation1 tt nm = Derivation (className $ traversalArg tt) (traversalInstance1 tt nm) +    where className n = nm ++ (if n > 1 then show n else "")+++-- | Instance for a Traversable like class with just 1 method+traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl]+traversalInstance1 tt nm (_,dat)+    | isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"+    | dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"+    | otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]+++-- | Instance for a Traversable like class+traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances Decl] -> [Decl]+traversalInstance tt nameBase dat bodyM = [simplify $ InstDecl sl ctx nam args (map InsDecl body)]+    where+        (body, required) = runWriter (sequence bodyM)+        ctx  = [ ClassA (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))+               | RequiredInstance n p <- S.toList required+               ]+        vrs  = vars tyVar 't' (dataDeclArity dat)+        (vrsBefore,_:vrsAfter) = splitAt (length vrs - traversalArg tt) vrs+        className n = nameBase ++ (if n > 1 then show n else "")+        nam = qname (className (traversalArg tt))+        args = TyParen (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter+++-- | Derive a 'traverse' like function+deriveTraversal :: TraveralType -> DataDecl -> WithInstances Decl+deriveTraversal tt dat = fun+    where+        fun  = (\xs -> FunBind [Match sl nam a b c d | Match _ _ a b c d <- xs]) <$> body+        args = argPositions dat+        nam = unqual $ traversalNameN tt $ traversalArg tt+        body = mapM (deriveTraversalCtor tt args) (dataDeclCtors dat)++        unqual (Qual _ x) = x+        unqual (UnQual x) = x+++-- | Derive a clause of a 'traverse' like function for a constructor+deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDecl -> WithInstances Match+deriveTraversalCtor tt ap ctor = do+    let nam = ctorDeclName ctor+        arity = ctorDeclArity ctor+    tTypes <- mapM (deriveTraversalType tt ap) (map (fromBangType . snd) $ ctorDeclFields ctor)+    return $ traverseFunc tt (PParen $ PApp (qname nam) (vars pVar 'a' arity))+           $ traverseCtor tt nam (zipWith App tTypes (vars var 'a' arity))++++-- | Derive a traversal for a type+deriveTraversalType :: TraveralType -> ArgPositions -> Type -> WithInstances Trav+deriveTraversalType tt ap (TyParen x) = deriveTraversalType tt ap x+deriveTraversalType tt ap TyForall{}  = fail "forall not supported in traversal deriving"+deriveTraversalType tt ap (TyFun a b)+                                           = fromJust (traverseArrow tt)+                                                 <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a+                                                 <*> deriveTraversalType tt                                     ap b+deriveTraversalType tt ap (TyApp a b)      = deriveTraversalApp tt ap a [b] -- T a b c ...+deriveTraversalType tt ap (TyList a)       = deriveTraversalType tt ap $ TyApp (TyCon $ Special ListCon) a+deriveTraversalType tt ap (TyTuple b a)    = deriveTraversalType tt ap $ tyApps (TyCon $ Special $ TupleCon b $ length a) a+deriveTraversalType tt ap (TyCon n)        = return $ traversalId tt -- T+deriveTraversalType tt ap (TyVar (Ident n)) -- a+  | ap n /= traversalArg tt                = return $ traversalId tt+  | traversalCo tt                         = fail "tyvar used in covariant position"+  | otherwise                              = return $ traversalDirect tt+++-- | Find all arguments to a type application, then derive a traversal+deriveTraversalApp :: TraveralType -> ArgPositions -> Type -> [Type] -> WithInstances Trav+deriveTraversalApp tt ap (TyApp a b) args = deriveTraversalApp tt ap a (b : args)+deriveTraversalApp tt ap tycon@TyTuple{} args = do -- (a,b,c)+         tArgs <- mapM (deriveTraversalType tt ap) args+         return $+           if (all (== traversalId tt) tArgs) then+             traversalId tt+           else+             Lambda sl [PTuple (vars pVar 't' (length args))]+                  (traverseTuple tt $ zipWith App tArgs (vars var 't' (length args)))+deriveTraversalApp tt ap tycon args = do -- T a b c+         tCon  <- deriveTraversalType tt ap tycon+         tArgs <- mapM (deriveTraversalType tt ap) args+         -- need instances?+         case tycon of+           TyVar (Ident n) | ap n == traversalArg tt -> fail "kind error: type used type constructor"+                   | otherwise               -> tell $ S.fromList+                                                [ RequiredInstance n i+                                                | (t,i) <- zip (reverse tArgs) [1..]+                                                , t /= traversalId tt+                                                ]+           _ -> return ()+         -- combine non-id traversals+         let nonId = [ traverseArg tt i t+                     | (t,i) <- zip (reverse tArgs) [1..]+                     , t /= traversalId tt+                     ]+         return $ case nonId of+           [] -> traversalId tt -- no interesting arguments to type con+           _  -> foldl1 (traversalPlus tt) nonId+++-- | Lift a traversal to the argument of a type constructor+traverseArg :: TraveralType -> Int -> Trav -> Trav+traverseArg tt n e   =  traversalFunc tt (traversalNameN tt n) e++traversalNameN :: TraveralType -> Int -> QName+traversalNameN tt n | n <= 1    = nm+                    | otherwise = nm `f` (if n > 1 then show n else "")+  where nm = traversalName tt+        f (Qual m x) y = Qual m $ x `g` y+        f (UnQual x) y = UnQual $ x `g` y+        g (Ident x) y = Ident $ x ++ y++-- | Information on argument positions+type ArgPositions = String -> Int++-- | Position of an argument in the data type+--   In the type  "data X a b c"+--   positions are: a -> 3, b -> 2, c -> 1+argPositions :: DataDecl -> String -> Int+argPositions dat = \nm -> case elemIndex nm args of+    Nothing -> error "impossible: tyvar not in scope"+    Just k  -> length args - k+ where args = dataDeclVars dat

@@ -1,32 +1,37 @@--{-# OPTIONS_GHC -fth -cpp #-}---- | A pseudo derivation.  For each constructor of the data type, @Is@--- generates @is@/CtorName/ which returns 'True' if given an object--- build using the appropriate constructor, and 'False' otherwise.-module Data.Derive.Is(makeIs) where--import Language.Haskell.TH.All---#ifdef GUESS--import Data.DeriveGuess+module Data.Derive.Is where+{- -example = (,) "Is" [d|+example :: Sample -    isCtorZero (CtorZero{}) = True; isCtorZero _ = False-    isCtorOne  (CtorOne {}) = True; isCtorOne  _ = False-    isCtorTwo  (CtorTwo {}) = True; isCtorTwo  _ = False-    isCtorTwo' (CtorTwo'{}) = True; isCtorTwo' _ = False+isFirst  (First {}) = True; isFirst  _ | length [First{},Second{},Third{}] > 1 = False+isSecond (Second{}) = True; isSecond _ | length [First{},Second{},Third{}] > 1 = False+isThird  (Third {}) = True; isThird  _ | length [First{},Second{},Third{}] > 1 = False -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeIs :: Derivation-makeIs = derivation is' "Is"-is' dat = ((map (\(ctorInd,ctor) -> (FunD (mkName ("is" ++ ctorName ctor)) [(-    Clause [((flip RecP []) (mkName ("" ++ ctorName ctor)))] (NormalB (ConE (-    mkName "True"))) []),(Clause [WildP] (NormalB (ConE (mkName "False"))) [])]-    )) (id (zip [0..] (dataCtors dat))))++[])+makeIs = derivationDSL "Is" dslIs++dslIs =+    MapCtor (App "FunBind" (List [List [App "Match" (List [App "Ident"+    (List [Concat (List [String "is",CtorName])]),List [App "PParen" (+    List [App "PRec" (List [App "UnQual" (List [App "Ident" (List [+    CtorName])]),List []])])],App "Nothing" (List []),App+    "UnGuardedRhs" (List [App "Con" (List [App "UnQual" (List [App+    "Ident" (List [String "True"])])])]),App "BDecls" (List [List []])+    ]),App "Match" (List [App "Ident" (List [Concat (List [String "is"+    ,CtorName])]),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 "BDecls" (List [List []])])]]))+-- GENERATED STOP

@@ -1,42 +1,39 @@---- | A pseudo derivation.  For each field in the data type, deriving--- @LazySet@ generates a function like a record updator, but lazy.--- This is very useful in certain situations to improve laziness--- properties.  Example:------ > data Foo = Foo { x :: Int, y :: Int, z :: Int }------ becomes:------ > setX v f = Foo v (y f) (z f)--- > setY v f = Foo (x f) v (z f)--- > setZ v f = Foo (x f) (y f) v-+{-|+    A pseudo derivation.  For each field in the data type, deriving+    @LazySet@ generates a function like a record updator, but lazy where possible.+    This is very useful in certain situations to improve laziness+    properties.  A setter is only lazy if that field is present in one constructor.+-} module Data.Derive.LazySet(makeLazySet) where+{- -import Language.Haskell.TH.All-import Data.Char-import Data.List+test :: Computer -{--data State = State {x :: Int, y :: Int}+setSpeed :: Int -> Computer -> Computer+setSpeed v x = x{speed=v} -==>+setWeight :: Double -> Computer -> Computer+setWeight v x = Laptop v (speed x) -setX a0 b0 = State a0 (y b0)-setY a0 b0 = State (x b0) a0+test :: Sample  -} +import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe++ makeLazySet :: Derivation-makeLazySet = derivation lazyset' "LazySet"+makeLazySet = Derivation "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d -lazyset' dat = map f fields++makeLazySetField :: DataDecl -> String -> [Decl]+makeLazySetField d field = [TypeSig sl [name fun] typ, bind fun [pVar "v",pVar "x"] bod]     where-        fields = nub $ concatMap (\f -> map ((,) f) (ctorFields f)) (dataCtors dat)+        fun = "set" ++ title field+        typ = t `TyFun` (dataDeclType d `TyFun` dataDeclType d)+        (t,c):tc = [(fromBangType t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field] -        f (ctor,field) = funN name [sclause [vr "a0", vr "b0"] (lK (ctorName ctor) body)]-            where-                name = "set" ++ toUpper (head field) : tail field-                body = [ if fld == field then vr "a0" else l1 fld (vr "b0")-                             | fld <- ctorFields ctor ]+        bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren $ App (var n) (var "x") | (n,t) <- ctorDeclFields c]+            | otherwise = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]

@@ -1,32 +1,55 @@---- | Derives an instance of @Monoid@. This derivation is limited to--- data types with only one constructor; it uses the product--- construction of monoids.+{-|+    Derives an instance of @Monoid@. It uses the product+    construction of monoids. @mappend@ on two different constructors+    is undefined.+-} module Data.Derive.Monoid(makeMonoid) where--import Language.Haskell.TH.All- {--data Foo = Foo a String--==>+import Data.Monoid hiding (First) -instance Monoid a => Monoid (Foo a) where-    mempty = Foo mempty mempty-    mappend (Foo x1 x2) (Foo y1 y2) = Foo (mappend x1 y1) (mappend x2 y2)+example :: Sample+instance Monoid a => Monoid (Sample a) where+    mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]+    mappend (First) (First) = First+    mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)+    mappend (Third x1) (Third y1) = Third (mappend x1 y1)  -}--makeMonoid :: Derivation-makeMonoid = derivation monoid' "Monoid"+-- GENERATED START -monoid' dat | length (dataCtors dat) == 1-         = [instance_default "Monoid" dat [funN "mempty" [empty],funN "mappend" [append]]]-    where-        ctor = head $ dataCtors dat+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation -        empty  = sclause [] $ lK (ctorName ctor) (replicate (ctorArity ctor) (l0 "mempty"))-        append = sclause [ctp ctor 'x',ctp ctor 'y'] $-                         lK (ctorName ctor) (zipWith (l2 "mappend") (ctv ctor 'x') (ctv ctor 'y'))+makeMonoid :: Derivation+makeMonoid = derivationDSL "Monoid" dslMonoid -monoid' dat = []+dslMonoid =+    List [Instance ["Monoid"] "Monoid" (List [App "InsDecl" (List [App+    "PatBind" (List [App "PVar" (List [App "Ident" (List [String+    "mempty"])]),App "Nothing" (List []),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 "BDecls" (List+    [List []])])]),App "InsDecl" (List [App "FunBind" (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 "BDecls"+    (List [List []])]))])])])]+-- GENERATED STOP

@@ -1,33 +1,35 @@-{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}---- | Derive NFData, from Control.Parallel.Strategies.-module Data.Derive.NFData(makeNFData) where--import Language.Haskell.TH.All---#ifdef GUESS--import Control.Parallel.Strategies-import Data.DeriveGuess+module Data.Derive.NFData where+{-+import "parallel" Control.Parallel.Strategies -example = (,) "NFData" [d|+example :: Sample+instance NFData a => NFData (Sample a) where+    rnf (First) = ()+    rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+    rnf (Third x1) = rnf x1 `seq` () -    instance (NFData a) => NFData (DataName a) where-        rnf CtorZero = ()-        rnf (CtorOne x1) = rnf x1 `seq` ()-        rnf (CtorTwo x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-        rnf (CtorTwo' x1 x2) = rnf x1 `seq` rnf x2 `seq` ()-    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeNFData :: Derivation-makeNFData = derivation nFData' "NFData"-nFData' dat = [instance_context ["NFData"] "NFData" dat [(FunD (mkName "rnf") (-    (map (\(ctorInd,ctor) -> (Clause [(ConP (mkName ("" ++ ctorName ctor)) ((-    map (\field -> (VarP (mkName ("x" ++ show field)))) (id [1..ctorArity ctor]-    ))++[]))] (NormalB (foldl1With (VarE (mkName "seq")) ((map (\field -> (AppE-    (VarE (mkName "rnf")) (VarE (mkName ("x" ++ show field))))) (id [1..-    ctorArity ctor]))++[(TupE [])]++[]))) [])) (id (zip [0..] (dataCtors dat)))-    )++[]))]]+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 "BDecls" (+    List [List []])]))])])])]+-- GENERATED STOP

@@ -1,75 +1,92 @@-{-# OPTIONS_GHC -fth -cpp #-}---- | Derive 'Ord', as specified in the Haskell 98 Language Report.-module Data.Derive.Ord(makeOrd) where--import Control.Monad(guard)-import Language.Haskell.TH.All--#ifdef GUESS--import Data.DeriveGuess+module Data.Derive.Ord where+{-+import Prelude -instance Eq (DataName a) where+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 & compare x2 y2 & EQ+            check (Third x1) (Third y1) = compare x1 y1 & EQ+            check x y | length [First{},Second{},Third{}] > 1 = compare (tag x) (tag y) -example = (,) "Ord" [d|+            EQ & x = x+            x & _ = x -    instance Ord a => Ord (DataName a) where-        compare a b = check a b-            where-                check CtorZero CtorZero = compare () ()-                check (CtorOne x1) (CtorOne y1) = compare (tup1 x1) (tup1 y1)-                check (CtorTwo x1 x2) (CtorTwo y1 y2) = compare (x1,x2) (y1,y2)-                check (CtorTwo' x1 x2) (CtorTwo' y1 y2) = compare (x1,x2) (y1,y2)-                check x y = compare (tag x) (tag y)-                -                tag (CtorZero{}) = 0-                tag (CtorOne{}) = 1-                tag (CtorTwo{}) = 2-                tag (CtorTwo'{}) = 3+            tag (First{}) = 0+            tag (Second{}) = 1+            tag (Third{}) = 2 -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeOrd :: Derivation-makeOrd = derivation ord' "Ord"-ord' dat = [instance_context ["Ord"] "Ord" dat [FunD (mkName "compare") [(Clause-    [(VarP (lName "a")),(VarP (lName "b"))] (NormalB (applyWith (VarE (lName-    "check")) [(VarE (lName "a")),(VarE (lName "b"))])) (FunD (lName "check"-    ) ((map (\ (_,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (-    \field -> (VarP (lName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[-    ])),(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (lName ("y" ++-    show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (applyWith (VarE (-    mkName "compare")) [(TupE ((map (\field -> (VarE (lName ("x" ++ show field-    )))) (id [1..ctorArity ctor]))++[])),(TupE ((map (\field -> (VarE (lName (-    "y" ++ show field)))) (id [1..ctorArity ctor]))++[]))])) [])) (id (zip [0..-    ] (dataCtors dat))))-    ++ emptyIfOneCtor-    [(Clause [(VarP (lName "x")),(VarP (lName "y"))] (-    NormalB (applyWith (VarE (mkName "compare")) [(AppE (VarE (lName "tag")) (-    VarE (lName "x"))),(AppE (VarE (lName "tag")) (VarE (lName "y")))])) [])-    ])-    : emptyIfOneCtor-    [FunD (lName "tag") ((map (\ (ctorInd,ctor) -> (Clause [((flip RecP [-    ]) (mkName (ctorName ctor)))] (NormalB (LitE (IntegerL ctorInd))) [])) (id-    (zip [0..] (dataCtors dat)))))] ))]]]-  where lName = mkName . (++ "_Data_Derive_Ord__")-        emptyIfOneCtor = (guard (length (dataCtors dat) > 1) >>)--{---- HAND WRITTEN VERSION--- requires O(n^2) page space (the automatic one is O(n))--ord' dat = simple_instance "Ord" dat [funN "compare" body]-    where-        obs  = zip [0..] (dataCtors dat)-        body = [ sclause [ctp (snd x) 'a', ctp (snd y) 'b'] (rule x y)-                     | x <- obs , y <- obs ]--rule (i1,c1) (i2,c2) | i1 < i2   = l0 "LT"-                     | i1 > i2   = l0 "GT"-                     | otherwise = l2 "compare" (tup2 c1 'a') (tup2 c2 'b')+makeOrd = derivationDSL "Ord" dslOrd -tup2 c ch = foldr (l2 "(,)") (lit ()) (ctv c ch)--}+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 "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 "Symbol" (List [String "&"+    ])])]),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 "BDecls" (List [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 "BDecls" (List [List []])])]])]),App "FunBind" (+    List [List [App "Match" (List [App "Symbol" (List [String "&"]),+    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 "BDecls" (List [List []])]),App "Match" (List [App+    "Symbol" (List [String "&"]),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 "BDecls" (List [+    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+    "Lit" (List [App "Int" (List [CtorIndex])])]),App "BDecls" (List [+    List []])]))])]])])]])])])]+-- GENERATED STOP

@@ -1,57 +0,0 @@--- NOTE: Cannot be guessed as it relies on type information---- | Derive Play, implemented for tuples and lists.-module Data.Derive.PlateDirect(makePlateDirect) where--import Language.Haskell.TH.All---makePlateDirect :: Derivation-makePlateDirect = derivation plateDirect' "PlateDirect"---plateDirect' :: Dec -> [Dec]-plateDirect' (DataD _ typ [] cs _) =-        [InstanceD [] (l2 "PlateAll" t t) [funN "plateAll" [sclause [] (l0 "plateSelf")]]-        ,InstanceD [] (l1 "PlateOne" t) [funN "plateOne" (map f cs)]-        ]-    where-        t = l0 $ show typ-        -        f x = sclause [ctp x 'x'] $ foldl1 AppE args-            where args = l1 "plate" (l0 $ ctorName x) : zipWith g (ctv x 'x') (ctorTypes x)-        -        g s (AppT (ConT c) t) | show c == "[]" = g s (AppT ListT t)-        g s (AppT ListT (ConT t)) | t == typ  = l1 "||*" s-        g s (AppT ListT _) = l1 "||+" s-        g s (ConT  t) | t == typ  = l1 "|*" s-        g s _ = l1 "|+" s--plateDirect' (NewtypeD a b c d e) = plateDirect' (DataD a b c [d] e)-plateDirect' _ = []--{---- an attempt at something better which doesn't really work--getTypes :: Type -> Q [Type]-getTypes t = do-        let (ConT c, cs) = typeApp t-        TyConI dat <- reify c-        return $ concatMap ctorTypes $ dataCtors dat---reaches :: Type -> Q [Type]-reaches t = f [] [t]-    where-        f done [] = return done-        f done (t:odo)-            | t `elem` done = f done odo-            | otherwise = do-                ts <- getTypes t-                f (t:done) (odo ++ ts)---against :: Type -> Type -> Type-against = error "here"---}

@@ -1,48 +1,58 @@-{-# OPTIONS_GHC -fth -cpp -fglasgow-exts -fallow-undecidable-instances #-}--module Data.Derive.PlateTypeable(makePlateTypeable) where--import Language.Haskell.TH.All---#ifdef GUESS--import Data.Generics.PlateTypeable-import Data.DeriveGuess-import Data.Typeable--example = (,) "PlateTypeable" [d|+module Data.Derive.PlateTypeable where+{-+import "uniplate" Data.Generics.PlateTypeable(PlateAll) -    instance (PlateAll a (DataName a), Typeable a) => Uniplate (DataName a) where-        uniplate = uniplateAll+example :: Sample -    instance (Typeable t, Typeable a, Uniplate t, PlateAll a t) => PlateAll (DataName a) t where-        plateAll CtorZero         = plate CtorZero-        plateAll (CtorOne x1)     = plate CtorOne  |+ x1-        plateAll (CtorTwo x1 x2)  = plate CtorTwo  |+ x1 |+ x2-        plateAll (CtorTwo' x1 x2) = plate CtorTwo' |+ x1 |+ x2+instance (PlateAll a (Sample a), Typeable a) => Uniplate (Sample a) where+    uniplate = uniplateAll -    |]+instance (Typeable t, Typeable a, Uniplate t, PlateAll a t) => PlateAll (Sample a) t where+    plateAll (First) = plate First+    plateAll (Second x1 x2)  = plate Second |+ x1 |+ x2+    plateAll (Third x1) = plate Third |+ x1 -#endif+-}+-- GENERATED START +import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makePlateTypeable :: Derivation-makePlateTypeable = derivation plateTypeable' "PlateTypeable"-plateTypeable' dat = [InstanceD (concat ([(map (\tdat -> (AppT (AppT (ConT (-    mkName "PlateAll")) tdat) (lK (dataName dat) (dataVars dat)))) (dataVars-    dat)),(map (\tdat -> (AppT (ConT (mkName "Typeable")) tdat)) (dataVars dat)-    )])) (head [(AppT (ConT (mkName "Uniplate")) (lK (dataName dat) (dataVars-    dat)))])[(ValD (VarP (mkName "uniplate")) (NormalB (VarE (mkName-    "uniplateAll"))) [])],InstanceD (concat ([[(AppT (ConT (mkName "Typeable"))-    (VarT (mkName "t")))],(map (\tdat -> (AppT (ConT (mkName "Typeable")) tdat)-    ) (dataVars dat)),[(AppT (ConT (mkName "Uniplate")) (VarT (mkName "t")))],(-    map (\tdat -> (AppT (AppT (ConT (mkName "PlateAll")) tdat) (VarT (mkName-    "t")))) (dataVars dat))])) (head [(AppT (AppT (ConT (mkName "PlateAll")) (-    lK (dataName dat) (dataVars dat))) (VarT (mkName "t")))])[(FunD (mkName-    "plateAll") ((map (\(ctorInd,ctor) -> (Clause [(ConP (mkName ("" ++-    ctorName ctor)) ((map (\field -> (VarP (mkName ("x" ++ show field)))) (id [-    1..ctorArity ctor]))++[]))] (NormalB (foldr1With (VarE (mkName "|+")) ((map-    (\field -> (VarE (mkName ("x" ++ show field)))) (reverse [1..ctorArity ctor-    ]))++[(AppE (VarE (mkName "plate")) (ConE (mkName ("" ++ ctorName ctor))))]-    ++[]))) [])) (id (zip [0..] (dataCtors dat))))++[]))]]+makePlateTypeable = derivationDSL "PlateTypeable" dslPlateTypeable++dslPlateTypeable =+    List [Instance ["PlateAll","Typeable"] "Uniplate" (List [App+    "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App+    "Ident" (List [String "uniplate"])]),App "Nothing" (List []),App+    "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App+    "Ident" (List [String "uniplateAll"])])])]),App "BDecls" (List [+    List []])])])]),App "InstDecl" (List [List [App "ClassA" (List [+    App "UnQual" (List [App "Ident" (List [String "Typeable"])]),List+    [App "TyVar" (List [App "Ident" (List [String "t"])])]]),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 "Uniplate"])]),List [App "TyVar" (List [App "Ident" (+    List [String "t"])])]]),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 "t"])])]])],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 "t"])])],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 "BDecls" (List [List []])]))])])]])]+-- GENERATED STOP

@@ -1,18 +1,168 @@---- | 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.+{-|+    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 Language.Haskell.TH.All+{-+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 (p0 > 10) (\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 p0 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.List-import Data.Char+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 = derivation read' "Read"+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 "BDecls" (List [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" =+    if hasFields $ getCtor d y+    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 [cpat, var ('r':show (cn+1))]) $+        matchStr (ctorDeclName c) 0 :+        [QualStmt $ Generator sl+            (PTuple [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 [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 [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 [PLit $ 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 ]@@ -47,3 +197,4 @@         pRead pc pat = pArse pat (l1 "readsPrec" (lit (pc :: Integer)))          pField pat fld = pLex fld . pLex "=" . pRead 0 pat+-}

@@ -1,25 +1,44 @@+{-|+    A pseudo derivation.  For each field in the data type, deriving+    @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =+    \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@. --- | A pseudo derivation.  For each field in the data type, deriving--- @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =--- \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.------ This is intended for use with the compositional functional references--- described in--- <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.+    This is intended for use with the compositional functional references+    described in+    <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.+-} module Data.Derive.Ref(makeRef) where -import Language.Haskell.TH.All-import Data.Char+{-+test :: Sample++test :: Computer++refSpeed :: Ref Computer+refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}++refWeight :: Ref Computer+refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}+-}++import Language.Haskell+import Data.Derive.Internal.Derivation import Data.List+import Data.Char + makeRef :: Derivation-makeRef = derivation ref' "Ref"+makeRef = Derivation "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d -ref' dat = map f fields++makeRefField :: DataDecl -> String -> [Decl]+makeRefField d field = [TypeSig sl [name ref] typ, bind ref [] bod]     where-        ctors = dataCtors dat-        fields = nub $ concatMap ctorFields ctors-        -        f field = funN ("ref" ++ toUpper (head field) : tail field) $-                       [sclause [] $ l2 "Ref" (vr field)-                                              (LamE [vr "f",vr "v"] (RecUpdE (vr "v") [(mkName field, l1 "f" (l1 field (vr "v")))]))]+        ref = "ref" ++ title field+        typ = TyApp (tyCon "Ref") (dataDeclType d)++        bod = RecConstr (qname "Ref")+            [FieldUpdate (qname "select") (var field)+            ,FieldUpdate (qname "update") $ Lambda sl [pVar "f",pVar "v"] $+                RecUpdate (var "v") [FieldUpdate (qname field) $ App (var "f") $ Paren $ App (var field) (var "v")]+            ]

@@ -1,57 +1,66 @@-{-# OPTIONS_GHC -fth -fno-warn-missing-methods -cpp #-}---- | Derivation for the @Serial@ class used by SmallCheck.  Following--- the guidelines in the SmallCheck README--- <http://www.cs.york.ac.uk/fp/darcs/smallcheck/README>, we implement--- both @series@ and @coseries@.  The generated instances use the--- SmallCheck instance combinators in the proscribed way.--module Data.Derive.Serial(makeSerial) where--import Language.Haskell.TH.All---#ifdef GUESS--import SmallCheck-import Data.DeriveGuess+module Data.Derive.Serial where+{-+import "smallcheck" Test.SmallCheck -example = (,) "Serial" [d|+example :: Sample -    instance Serial a => Serial (DataName a) where-        series = cons0 CtorZero \/-                 cons1 CtorOne  \/-                 cons2 CtorTwo  \/-                 cons2 CtorTwo'+instance Serial a => Serial (Sample a) where+    series = cons0 First \/+             cons2 Second \/+             cons1 Third -        coseries d = [ \t -> case t of-                                CtorZero -> t0-                                CtorOne x1 -> t1 x1-                                CtorTwo x1 x2 -> t2 x1 x2-                                CtorTwo' x1 x2 -> t3 x1 x2-                     | t0 <- alts0 d-                     , t1 <- alts1 d-                     , t2 <- alts2 d-                     , t3 <- alts2 d-                     ]+    coseries rs d = [ \t -> case t of+                                First -> t0+                                Second x1 x2 -> t1 x1 x2+                                Third x1 -> t2 x1+                    | t0 <- alts0 rs d `const` First{}+                    , t1 <- alts2 rs d `const` Second{}+                    , t2 <- alts1 rs d `const` Third{}+                    ] -    |]+-}+-- GENERATED START -#endif+import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation  makeSerial :: Derivation-makeSerial = derivation serial' "Serial"-serial' dat = [instance_context ["Serial"] "Serial" dat [ValD (VarP (mkName-    "series")) (NormalB (foldl1With (VarE (mkName "\\/")) ((map (\(ctorInd,ctor-    ) -> (AppE (VarE (mkName ("cons" ++ show (ctorArity ctor)))) (ConE (mkName-    (ctorName ctor))))) (id (zip [0..] (dataCtors dat))))++[]))) [],FunD (-    mkName "coseries") [(Clause [(VarP (mkName "d"))] (NormalB (CompE ((map (\(-    ctorInd,ctor) -> (BindS (VarP (mkName ("t" ++ show ctorInd))) (AppE (VarE (-    mkName ("alts" ++ show (ctorArity ctor)))) (VarE (mkName "d"))))) (id (zip-    [0..] (dataCtors dat))))++[(NoBindS (LamE [(VarP (mkName "t"))] (CaseE (-    VarE (mkName "t")) ((map (\(ctorInd,ctor) -> (Match (ConP (mkName (ctorName-    ctor)) ((map (\field -> (VarP (mkName ("x" ++ show field)))) (id [1..-    ctorArity ctor]))++[])) (NormalB (applyWith (VarE (mkName ("t" ++ show-    ctorInd))) ((map (\field -> (VarE (mkName ("x" ++ show field)))) (id [1..-    ctorArity ctor]))++[]))) [])) (id (zip [0..] (dataCtors dat))))++[]))))]++[-    ]))) [])]]]+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 "Nothing" (List []),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 "BDecls" (List [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 "UnGuardedAlt" (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 "BDecls" (List [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 "BDecls" (List [List []])])]+    ])])])]+-- GENERATED STOP

@@ -1,34 +1,40 @@---- | A pseudo derivation.  For each field in the data type, deriving--- @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.--- This derivation is intended to work around the fact that in Haskell--- assigning to a field is not a first class object (although--- extracting from a field is).+{-|+    A pseudo derivation.  For each field in the data type, deriving+    @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.+    This derivation is intended to work around the fact that in Haskell+    assigning to a field is not a first class object (although+    extracting from a field is).+-} module Data.Derive.Set(makeSet) where -import Language.Haskell.TH.All-import Data.Char-import Data.List- {--data Computer = Laptop {weight :: Int, memory :: Int}-              | Desktop {memory :: Int, processor :: Int} -==>+test :: Computer +setSpeed :: Int -> Computer -> Computer+setSpeed v x = x{speed=v}++setWeight :: Double -> Computer -> Computer setWeight v x = x{weight=v}-setMemory v x = x{memory=v}-setProcessor v x = x{process=v} +test :: Sample+ -} +import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe++ makeSet :: Derivation-makeSet = derivation set' "Set"+makeSet = Derivation "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d -set' dat = map f fields++makeSetField :: DataDecl -> String -> [Decl]+makeSetField d field = [TypeSig sl [name set] typ, bind set [pVar "v",pVar "x"] bod]     where-        ctors = dataCtors dat-        fields = nub $ concatMap ctorFields ctors-        -        f field = funN ("set" ++ toUpper (head field) : tail field) $-                       [sclause [vr "v",vr "x"] $ RecUpdE (vr "x") [(mkName field,vr "v")]]+        set = "set" ++ title field+        typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d)+        typField = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d++        bod = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]

@@ -6,31 +6,85 @@ -- the @(@/consym/@)@ syntax. module Data.Derive.Show(makeShow) where -import Language.Haskell.TH.All+{-+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 p 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 p (Laptop x1 x2) =+        showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'+    showsPrec p (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 = derivation show' "Show"+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+    "BDecls" (List [List []])]))])])])]+-- GENERATED STOP -show' dat = [instance_default "Show" dat [funN "showsPrec" body]]-    where-        body = [ sclause [vr vname, ctp ctr 'x'] rhs-               | ctr <- dataCtors dat, let (vname, rhs) = showit ctr ]+-- Left is a literal string, Right is a variable -showit ctr = case ctorFields ctr of [] -> ("p", norm)-                                    fl -> ("_", flds fl)+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-        norm = l2 "showParen" (vr "p" >: lit (10::Integer))-               ((.::) (intersperse (scl ' ')-                       (ssl pname : map (l2 "showsPrec" (lit (11::Integer))) (ctv ctr 'x'))))+        fields = any (not . null . fst) (ctorDeclFields c)+        c = dataDeclCtors (snd d) !! fromInteger y -        flds f = (.::) (ssl (pname ++ " {") : fields f ++ [scl '}'])+        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] -        fields [] = []-        fields fs = scl ' ' : concat (intersperse [ssl ", "] (map field (zip (ctv ctr 'x') fs))) ++ [scl ' ']+        compress (Left x:Left y:z) = compress $ Left (x++y) : z+        compress (x:y) = x : compress y+        compress [] = [] -        field (v,f) = [ ssl (f ++ " = ") , l2 "showsPrec" (lit (0::Integer)) v ]+        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 -        ssl = l1 "showString" . lit ; scl = l1 "showChar" . lit -        pname = show (ppr (mkName (ctorName ctr)))+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,26 +0,0 @@--- NOTE: Cannot be guessed as it inducts on the data type (not its constructors)---- | Type level typeable, as used by the undecidable-instances version--- of the @TypeEq@ class from Oleg and Lammel's HList library.  The--- type numbers used are autmatically generated using a little-endian--- @Enum@ representation of the type's name.  Note that we truncate--- characters above 255, and ignore the module name, though the--- consequences are much less severe than in the @Typeable@ case since--- no coercion is involved.-module Data.Derive.TTypeable(makeTTypeable) where--import Language.Haskell.TH.All-import Data.Char-import Data.Bits--makeTTypeable :: Derivation-makeTTypeable = derivation ttypeable' "TTypeable"-ttypeable' dat = [InstanceD ctx hd []]-    where-        bits x = [ if x .&. mask /= 0 then hSucc' hZero' else hZero' | mask <- [1,2,4,8,16,32,64,128] ]-        bitnam = foldr hCons' hNil' (concatMap (bits . ord) (dataName dat))--        hd = l2 "TTypeable" (lK (dataName dat) (vrs 't')) (foldr hCons' hNil' (bitnam : vrs 'n'))-        ctx = zipWith (l2 "TTypeable") (vrs 't') (vrs 'n')--        vrs = flip vars (dataArity dat)

@@ -12,10 +12,30 @@  module Data.Derive.Traversable(makeTraversable, makeTraversableN) where -import Language.Haskell.TH.All-import Data.DeriveTraversal+{-+import Data.Traversable+import Control.Applicative(pure, (<*>)) +instance Traversable (FailList t1) where+    traverse _f (Zero) = pure Nil+    traverse _f (Fail a1) = pure (Fail 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 @@ -23,13 +43,14 @@ makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable"  traverseTraversal = defaultTraversalType-        { traversalName  = "traverse"-        , traversalId    = l0 "pure"+        { traversalName  = qname "traverse"+        , traversalId    = var "pure"         , traversalPlus  = fail "variable used in multiple positions in a data type"-        , traverseTuple  = \args -> liftAN (ConE $ tupleDataName $ length args) args-        , traverseCtor   = \ctor -> liftAN (l0 ctor)-        , traverseFunc   = \pat rhs -> sclause [vr "_f", pat] rhs+        , 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) (BDecls [])         }  liftAN :: Exp -> [Exp] -> Exp-liftAN base args = foldl (l2 "<*>") (l1 "pure" base) args+liftAN base args = foldl (<*>) (appP (var "pure") base) args+    where x <*> y = InfixApp (paren x) (QVarOp $ UnQual $ Symbol "<*>") (paren y)

@@ -1,23 +1,46 @@--- NOTE: Cannot be guessed as it inducts on the data type (not its constructors)---- | 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.------ The generated 'TypeRep' uses only the base name of the type, so--- identically named types in different modules can be treated as the--- same, with disasterous consequences.------ Also creates a @typename_\<the type name\>@ value to hold the--- 'TypeRep'.+{-|+    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 -import Language.Haskell.TH.All-import Data.Char+test :: Bool+typename_Bool :: TyCon+typename_Bool = mkTyCon "Example.Bool"+instance Typeable Bool where+    typeOf _ = mkTyConApp typename_Bool [] +test :: Sample+typename_Sample :: TyCon+typename_Sample = mkTyCon "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 = mkTyCon "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  {-@@ -47,17 +70,27 @@   makeTypeable :: Derivation-makeTypeable = derivation typeable' "Typeable"-typeable' dat = (funN nam [sclause [] (l1 "mkTyCon" $ lit . show $ qualifiedDataName dat)])-                : map f [0..dataArity dat]+makeTypeable = Derivation "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) Nothing (UnGuardedRhs bod) (BDecls []) |+        let bod = App (var "mkTyCon") (Lit $ String $ modu ++ "." ++ 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 = [if x == '.' then '_' else x | x <- "typename_" ++ dataName dat]+        nam = dataDeclName d+        fun = "typename_" ++ nam+        n = length $ dataDeclVars d -        f n = InstanceD (map (l1 "Typeable") vars)-                        (l1 ("Typeable"++sn) $ lK (dataName dat) vars)-                        [funN ("typeOf"++sn) [sclause [WildP | n == 0] def]]-            where-                def = if n == 0 then l2 "mkTyConApp" (l0 nam) (lst [])-                                else l0 ("typeOf" ++ sn ++ "Default")-                vars = take n $ map (vr . (:"")) ['a'..]-                sn = let i = dataArity dat - n in if i == 0 then "" else show i++inst ctxt n typ pat expr =+    InstDecl sl ctxt (qname $ "Typeable" ++ n) typ+        [InsDecl $ bind ("typeOf" ++ n) pat expr]++showN 0 = ""+showN n = show n

@@ -1,232 +0,0 @@--- NOTE: Cannot be guessed as it relies on type information---- | Derive Play, implemented for tuples and lists.-module Data.Derive.Uniplate(makeUniplate) where--import Language.Haskell.TH.All-import Data.List-import Data.Maybe-import Data.Generics-import qualified Data.Map as Map-import Control.Monad.State-import Debug.Trace----makeUniplate :: Derivation-makeUniplate = derivation uniplate' "Uniplate"---data Container = None | Target-               | List Container | Tuple [Container]-                 deriving (Eq, Show)----- convert a type to the appropriate container type-typeToContainer :: String -> Type -> Container-typeToContainer active t =-        if eqConT active name then Target-        else if all (== None) rest2 then None-        else if name == ListT then List (head rest2)-        else if isTupleT name then Tuple rest2-        else error $ "Uniplate derivation on unknown type: " ++ show t-    where-        (name,rest) = typeApp t-        rest2 = map (typeToContainer active) rest----- the variable type-type Var x = State (Map.Map String Int) x--getVar :: String -> Var String-getVar x = do mp <- get-              let i = Map.findWithDefault 1 x mp-              put $ Map.insert x (i+1) mp-              return $ x ++ if i == 1 then "" else show i--runVar :: Var a -> a-runVar x = evalState x Map.empty----uniplate' dat =-        [instance_default "Uniplate" dat [funN "uniplate" rbody]]-    where-        ctors :: [(CtorDef,[Container])]-        ctors = [(c, map (typeToContainer (dataName dat)) (ctorTypes c)) | c <- dataCtors dat]---        gbody = [sclause [ctp (fst c) 'x'] (gitem c) | c <- ctors]--        gitem :: (CtorDef,[Container]) -> Exp-        gitem (c,ts) = (++::) [AppE (f t) v | (t,v) <- zip ts (ctv c 'x')]-            where-                f None = const' nil-                f Target = LamE [vr "x"] (box (vr "x"))-                f (List t) = l1 "concatMap" (f t)-                f (Tuple ts) = LamE [tup (map vr vars)] ((++::) [AppE (f t) (vr v) | (t,v) <- zip ts vars])-                    where vars = ['x':show i | i <- [1..length ts]]---        rbody = [Clause [vr "x"] (NormalB $ case' (vr "x")-                    [(ctp (fst c) 'x', tup [gitem c, ritem c]) | c <- ctors]-                ) [funcList]]-        -        -        funcList = funN "list'"-                        [sclause [vr "f",nil] (runVar $ const1_ nil)-                        ,sclause [vr "f",lK ":" [vr "x",vr "xs"]]-                            (runVar $ do-                                a <- const1_ (l0 ":")-                                lhs <- join_ a (l1 "f" (vr "x"))-                                join_ lhs (lK "list'" [vr "f",vr "xs"])-                        )]--        -        wildcard :: Exp -> Exp-        wildcard x = everywhere (mkT f) x-            where-                vars = everything (++) ([] `mkQ` g) x-                -                g (VarE x) = [x]-                g x = []-                -                f (VarP x) | x `notElem` vars = WildP-                f x = x-        -        -        ritem :: (CtorDef,[Container]) -> Exp-        ritem (c,ts) = wildcard $ runVar (value_ $ joins_ (l0 (ctorName c)) items)-            where-                items = zip ts (ctv c 'x')-            -                f None = const_-                f Target = id_-                f (List t) = list_ (f t)-                f (Tuple ts) = do-                    vars1 <- replicateM (length ts) (getVar "x")-                    vars2 <- replicateM (length ts) (getVar "y")-                    bod <- joins_ (LamE (map vr vars1) (tup $ map vr vars1)) (zip ts (map vr vars2))-                    return $ LamE [tup $ map vr vars2] bod--                joins_ root xs = do-                    root2 <- const1_ root-                    xs2 <- mapM (\(t,v) -> liftM (`appE` v) (f t)) xs-                    foldM join_ root2 xs2---       -- the replaceChildren combinators-        -        const_ = do-            y <- getVar "y"-            ns <- getVar "ns"-            c <- getVar "c"-            return $ lamE [vr y,vr ns,vr c] (app (vr c) [vr y,vr ns])--        id_ = do-            n <- getVar "n"-            ns <- getVar "ns"-            c <- getVar "c"-            return $ lamE [WildP,lK ":" [vr n,vr ns],vr c] (app (vr c) [vr n,vr ns])-        -        isId (LamE [WildP,ConP cons [VarP n, VarP ns],VarP c] (AppE (AppE (VarE c2) (VarE n2)) (VarE ns2)))-            | show cons == ":" && n == n2 && c == c2 && ns == ns2 = True-        isId _ = False-        -        list_ x = liftM (l1 "list'") x-        -        value_ inp = do-            inp <- inp-            ns <- getVar "ns"-            y <- getVar "y"-            return $ lamE [vr ns] $ appE2 inp (vr ns) $ lamE [vr y,WildP] (vr y)--        join_ ina inb = do-            ns1 <- getVar "ns"-            ns2 <- getVar "ns"-            ns3 <- getVar "ns"-            c <- getVar "c"-            a <- getVar "a"-            b <- getVar "b"-            return $ lamE [vr ns1,vr c]-                   $ appE2 ina (vr ns1) $ lamE [vr a,vr ns2]-                   $ appE2 inb (vr ns2) $ lamE [vr b,vr ns3]-                   $ appE2 (vr c) (appE (vr a) (vr b)) (vr ns3)--        const1_ x = do c <- const_ ; return $ appE c x----        -- can be a bit more fast and loose about variable clashes etc-        -- since we guarantee a limited set of generated values--        -- very special rule, only valid for play-        appE (AppE (AppE (AppE (VarE l) i) x) y) (LamE (b:WildP:bs) c)-            | show l == "list'" && isId i = appE (lamE (b:bs) c) y--        appE (LamE (VarP x:xs) y) z = lamE xs (rebuild $ replaceVar x z y)-        appE (LamE (WildP :xs) y) z = lamE xs y-        appE (AppE (LamE (x1:VarP x2:xs) xb) y) z =-              AppE (lamE (x1:xs) (rebuild $ replaceVar x2 z xb)) y-        appE x y = AppE x y-        -        -        -        -        appE2 x y z = appE (appE x y) z-        -        lamE [] y = y-        lamE xs (LamE ys z) = lamE (xs++ys) z-        lamE xs (AppE y (VarE z)) | last xs == VarP z = lamE (init xs) y-        lamE x  y = LamE x y--        rebuild :: Exp -> Exp-        rebuild = everywhere (mkT f)-            where-                f (AppE x y) = appE x y-                f (LamE x y) = lamE x y-                f x = x---{---- ATTEMPT BASED ON THE RULES IN THE PAPER--- GOT BORED TOO QUICKLY...---data Env = Env {prefix :: String, unit_ :: Exp, target_ :: Type -> Maybe Exp, join_ :: [Exp] -> Exp}---- RULES FROM THE PAPER-d_ :: Env -> Dec -> Dec-d_ e (NewtypeD x1 x2 x3 x4 x5) = d_ e (DataD x1 x2 x3 [x4] x5)-d_ e (DataD _ name targs cs _) =-    FunD (mkName $ prefix e ++ show name) (map (c_ e (map VarP targs)) cs)--c_ :: Env -> [Pat] -> Con -> Clause-c_ e ps (NormalC name fields) = Clause (ps ++ [ConP name $ map (VarP . mkName) vs])-        (NormalB $ join_ e (AppE (unit_ e) (ConE name) : fs))-        []-    where-        vs = map (('v':) . show) [1..length fields]-        fs = zipWith AppE (map (t_ e . snd) fields) (map (VarE . mkName) vs)--t_ :: Env -> Type -> Exp-t_ e (VarT x) = VarE x---test = do-    i <- runQ dec-    putStrLn $ pprint $ uniplate' $ head i--env = Env "prefix_" (VarE $ mkName "unit") (const Nothing) ListE--dec = [d| data Foo a = FooM a | FooN |]---uniplate' dat = [instance_default "Uniplate" dat-        [FunD (mkName "replaceChildren") bod]]-    where-        bod = [Clause [vr "x"] (NormalB $ tup [l0 "getChildren", l0 "setChildren"]) [getC,setC]]-        -        getC = funN "getChildren" [sclause [] (vr "x")]-        setC = funN "setChildren" [sclause [] (vr "x")]--}

@@ -1,39 +1,47 @@--- | A Pseudo derivation. For every label, creates a function--- foo_u and foo_s which updates and sets the label respectively,--- e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'+{-|+    A Pseudo derivation. For every label, creates a function+    foo_u and foo_s which updates and sets the label respectively,+    e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'+-} module Data.Derive.Update(makeUpdate) where -import Language.Haskell.TH.All-import Data.Char-import Data.List {--data Computer = Laptop {weight :: Int, memory :: Int}-              | Desktop {memory :: Int, processor :: Int} -==>+test :: Computer -weight_u f r = r{weight = f (weight r)}-weight_s v = weight_u (const v)-memory_u f r = r{memory = f (memory r)}-memory_s v = memory_u (const v)-processor_u f r = r{processor = f (processor r)}-processor_s v = processor_u (const v)+speed_u :: (Int -> Int) -> Computer -> Computer+speed_u f x = x{speed = f (speed x)} +speed_s :: Int -> Computer -> Computer+speed_s v x = x{speed = v}++weight_u :: (Double -> Double) -> Computer -> Computer+weight_u f x = x{weight = f (weight x)}++weight_s :: Double -> Computer -> Computer+weight_s v x = x{weight = v}++test :: Sample+ -} +import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe++ makeUpdate :: Derivation-makeUpdate = derivation update' "Update"+makeUpdate = Derivation "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d -update' dat = concatMap f fields++makeUpdateField :: DataDecl -> String -> [Decl]+makeUpdateField d field =+        [TypeSig sl [name upd] (TyParen (TyFun typF typF) `TyFun` typR)+        ,bind upd [pVar "f",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (App (var "f") (Paren $ App (var field) (var "x")))]+        ,TypeSig sl [name set] (typF `TyFun` typR)+        ,bind set [pVar "v",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]]     where-        ctors = dataCtors dat -- constructors of the data type-        fields = nub $ concatMap ctorFields ctors -- get all of the fields of every data type-        -        f field = [ funN (field ++ "_u") $-                     [sclause [vr "f",vr "r"] -                                  $ RecUpdE (vr "r") [( mkName field-                                                      , AppE (vr "f") $ AppE (vr field) (vr "r"))]]-                  , funN (field ++ "_s") $-                       [sclause [vr "v"] $ AppE (VarE (mkName $ field++"_u")) -                                                (AppE (vr "const") $ vr "v")]-                  ]+        set = field ++ "_s"+        upd = field ++ "_u"+        typR = dataDeclType d `TyFun` dataDeclType d+        typF = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d

@@ -0,0 +1,22 @@++module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where++import Data.Derive.DSL.Derive+import Data.Derive.DSL.Apply+import Data.Derive.DSL.DSL+import Data.Derive.DSL.HSE+import Data.Derive.DSL.SYB+import Data.Maybe+import Data.Generics.PlateData+++deriveDSL :: [Decl] -> Maybe DSL+deriveDSL = listToMaybe . derive+++applyDSL :: DSL -> DataDecl -> Either String [Decl]+applyDSL dsl inp = Right $ simplify $ apply dsl $ toInput inp+++dynamicDSL :: DSL -> Maybe [Decl]+dynamicDSL = dslSYB

@@ -1,413 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-methods #-}--module Data.DeriveGuess(DataName(..), tup1, guess) where--import Language.Haskell.TH.All-import Data.Generics-import Data.List-import Data.Char-import Data.Maybe---data DataName a = CtorZero-                | CtorOne  a-                | CtorTwo  a a-                | CtorTwo' a a--ctorNames = ["CtorZero","CtorOne","CtorTwo","CtorTwo'"]---- | Guess an instantiator from a sample instance.-guess :: (String, Q [Dec]) -> IO ()-guess (name,x) = runQ x >>= putStr . (++) line0. widthify . (++) line1 . guessStr . unQ-    where-        line0 = "make" ++ name ++ " :: Derivation\n" ++-                "make" ++ name ++ " = derivation " ++ lname ++ "' \"" ++ name ++ "\"\n"-        line1 = lname ++ "' dat = "-        lname = toLower (head name) : tail name---- | A fake constructor for the unary tuple.  Helps 'guess' to see--- patterns in progressions of differently sized tuples.-tup1 = id---- | Chop and mangle a String representing Haskell code so that it--- fits in 80 columns, without regard for prettiness.-widthify :: String -> String-widthify xs = g 80 (f xs)-    where-        g n (x:xs) | n - length x <= 0 = "\n    " ++ g 76 ([x|x/=" "] ++ xs)-                   | otherwise = x ++ g (n - length x) xs-        g n [] = "\n"---        f (x:xs) | isSpace x = " " : f (dropWhile isSpace xs)-        f x = case lex x of-                 [("","")] -> []-                 -- \\ must not occur at the end of a line (CPP restrictions)-                 [("\\",y)] -> let a:b = f y in ('\\':a) : b-                 [(x,y)] -> x : f y---- | Process a tree produced by a quasiquote, stripping name--- uniquifiers and changing applications and tuplings into a standard--- form.-unQ :: [Dec] -> [Dec]-unQ x = everywhere (mkT g) $ everywhere fAny $ map normData x-    where-        fAny :: (Typeable a, Data a) => a -> a-        fAny = mkT fE `extT` fP-        fE (VarE x) = VarE (f x); fE x = x-        fP (VarP x) = VarP (f x); fP x = x--        -- | Remove_0 evil_1 ghc_2 name_3 uniquifiers_4-        f :: Name -> Name-        f name = if not ("_" `isSuffixOf` s) && match s then mkName $ dropUnder s else name-            where-                s = show name-                match = isPrefixOf "_" . dropWhile isDigit . reverse--        -- | Turn infix applications into prefix, and normalise-        -- tuples.-        g :: Exp -> Exp-        g (InfixE (Just x) y (Just z)) = AppE (AppE y x) z-        g (AppE (VarE tup) x) | show tup == "tup1" = TupE [x]-        g (ConE unit) | show unit == "()" = TupE []-        g x = x----- | Drop the first _ and everything after it; used to trim GHC name--- uniques.-dropUnder = reverse . drop 1 . dropWhile (/= '_') . reverse--list x = "[" ++ concat (intersperse "," x) ++ "]"--unwordsb x = "(" ++ unwords x ++ ")"--fst3 (a,b,c) = a-snd3 (a,b,c) = b-thd3 (a,b,c) = c--snub x = nub $ sort x--arityToCtors x = x : [3 | x == 2]-ctorToArity  x = if x == 3 then 2 else x--ctorArityEnv (Ctor i) = ctorToArity i--on op get a b = op (get a) (get b)----- imagine the following environment table:-{--[("CtorZero",0,0,[])-,("CtorOne" ,1,1,[1])-,("CtorTwo" ,2,2,[1,2])-,("CtorTwo'",2,3,[1,2])-]--}--data Env = None | Ctor Int | Field Int-         deriving (Show,Eq)--isField (Field _) = True; isField _ = False-isCtor  (Ctor  _) = True; isCtor  _ = False--fromField (Field i) = i-fromCtor  (Ctor  i) = i--fromEnv (Field i) = i-fromEnv (Ctor  i) = i------ Show t and Ppr t for better error messages--- Eq t required for hypothesis testing-class (Ppr t, Eq t, Show t) => Guess t where-    -- invariant: all answers must be correct for this example-    -- will never be given a different type of environment-    guessEnv :: t -> [(Env, Env -> t, String)]-    -guessStr :: Guess t => t -> String-guessStr t = case [s | (None,_,s) <- guessEnv t] of-                  [] -> error $ "\n\nNo hypothesis for:\n" ++ show t ++-                                "\n\nPretty version:\n" ++ show (ppr t)-                  (x:xs) -> x---checkGuess :: (Ppr t, Eq t, Show t) => t -> [(Env, Env -> t, String)] -> [(Env, Env -> t, String)]-checkGuess t xs = map f xs-    where-        f o@(env,gen,str) | t == gen env = o-                          | otherwise = error $ unlines ["checkGuess failed:"-                                                        ,"INPUT : " ++ show t-                                                        ,"OUTPUT: " ++ show (gen env)-                                                        ,"ENV   : " ++ show env-                                                        ,"HYP   : " ++ str-                                                        ]---guessEnvStr :: Guess t => t -> [(Env, Env -> t, String)]-guessEnvStr t = [(None, const t, guessStr t)]---guessPairStr :: (Guess a, Guess b) => String -> a -> b -> String-guessPairStr sjoin a b = sjoin ++ " " ++ guessStr a ++ " " ++ guessStr b--guessTripStr :: (Guess a, Guess b, Guess c) => String -> a -> b -> c -> String-guessTripStr sjoin a b c = unwords [sjoin, guessStr a, guessStr b, guessStr c]---joinEnvs :: [Env] -> Maybe Env-joinEnvs xs = if length ys > 1 then Nothing else Just $ head (ys ++ [None])-    where ys = filter (/= None) $ nub xs--guessOneEnv :: Guess a => (a -> t) -> String -> a -> [(Env, Env -> t, String)]-guessOneEnv fjoin sjoin x1 =-    [ (e1, \e -> fjoin (f1 e), unwordsb [sjoin,s1])-    | (e1,f1,s1) <- guessEnv x1]---- to join two elements either they are the same env, or one has None-guessPairEnv :: (Guess a, Guess b) => (a -> b -> t) -> String -> a -> b -> [(Env, Env -> t, String)]-guessPairEnv fjoin sjoin x1 x2 =-    [ (env, \e -> fjoin (f1 e) (f2 e), unwordsb [sjoin,s1,s2])-    | (e1,f1,s1) <- guessEnv x1-    , (e2,f2,s2) <- guessEnv x2-    , Just env <- [joinEnvs [e1,e2]]]--guessTripEnv :: (Guess a, Guess b, Guess c) => (a -> b -> c -> t) -> String -> a -> b -> c -> [(Env, Env -> t, String)]-guessTripEnv fjoin sjoin x1 x2 x3 =-    [ (env, \e -> fjoin (f1 e) (f2 e) (f3 e), unwordsb [sjoin,s1,s2,s3])-    | (e1,f1,s1) <- guessEnv x1-    , (e2,f2,s2) <- guessEnv x2-    , (e3,f3,s3) <- guessEnv x3-    , Just env <- [joinEnvs [e1,e2,e3]]]----instance Guess a => Guess [a] where-    guessEnv os = concatMap f $ mapM guessEnv os-        where-            -- first try and induct based on the length of the list-            f xs | all (== None) (map fst3 xs) &&-                   length xs == 2 &&-                   length vals == 1-                 = [(Ctor i, \e -> replicate (ctorArityEnv e) (head vals),-                             "(replicate (ctorArity ctor) " ++ thd3 (head xs) ++ ")")-                   | i <- [2,3]] ++-                   [(None, \e -> map ($ e) gens, list strs)]-                 where-                    (envs,gens,strs) = unzip3 xs-                    vals = nub $ zipWith ($) gens envs--        -            f xs | length es <= 1 = [(head (es ++ [None]), \e -> map ($ e) gens, list strs)]-                 | otherwise = [(env,gen,"("++str++")")-                               | env <- newEnvs, (gen,str) <- nubBy ((==) `on` snd) $ g xs]-                where-                    (envs,gens,strs) = unzip3 xs-                    es = nub $ filter (/= None) envs-                    -                    ctors = snub [i | Ctor i <- envs]-                    fields = snub [i | Field i <- envs]-                    maxField = maximum fields-                    -                    newEnvs = case ctors of-                                  [] -> map Ctor $ arityToCtors maxField-                                  _ | null fields -> [None]-                                  [x] | ctorToArity x == maxField -> [Ctor x]-                                  _ -> []  -                    -                    ctorEnv = head newEnvs == None-                    varName = if ctorEnv then "(ctorInd,ctor)" else "field"-                    -                    domain = if ctorEnv then [0..3] else [1..maxField]-                    getDomain (Ctor i) = take 2 [1..i]-                    getDomain None = [0..3]-                    getDomain _ = []-                    strDomain = if ctorEnv then "(zip [0..] (dataCtors dat))" else "[1..ctorArity ctor]"-                    -                    construct = if ctorEnv then Ctor else Field-                    -                    isNone x = x == None || (not ctorEnv && isCtor x)-                    -                    g :: Eq t => [(Env, Env -> t, String)] -> [(Env -> [t], String)]-                    g [] = [(\e -> [], "[]")]-                    g ((none,gn,st):xs) | isNone none =-                        [(\e -> gn e : gen e, "[" ++ st ++ "]++" ++ str) | (gen,str) <- g xs]-                    -                    g xs =  h id "id" xs ++ h reverse "reverse" xs--                    h :: Eq t => ([Int] -> [Int]) -> String -> [(Env, Env -> t, String)] -> [(Env -> [t], String)]-                    h fdir sdir xs-                        | map construct (fdir domain) `isPrefixOf` map fst3 xs-                        = [(\e -> map (fhyp . construct) (fdir $ getDomain e) ++ gen e-                           ,"(map (\\" ++ varName ++ " -> " ++ shyp ++ ") (" ++ sdir ++ " " ++ strDomain ++ "))++" ++ str)-                          | (fhyp,shyp) <- validHyp-                          , (gen,str) <- g rest]-                        where-                            (now,rest) = splitAt (length domain) xs--                            validHyp = filter (\hyp -> all (valid (fst hyp)) now) (map (\(a,b,c) -> (b,c)) now)-                            valid hyp (e,gen,_) = hyp e == gen e--                    h _ _ _ = []---guessType :: Type -> Type -> String-guessType principle x =-        if hasPrinciple then "(map (\\tdat -> " ++ disp x ++ ") (dataVars dat))" else "[" ++ disp x ++ "]"-    where-        hasPrinciple = f x-            where-                f x | x == principle = True-                f (AppT (ConT x) y) | show x == "DataName" = False-                f (AppT a b) = f a || f b-                f _ = False--        disp x | x == principle = "tdat"-        disp (AppT (ConT x) y) | show x == "DataName" = "(lK (dataName dat) (dataVars dat))"-        disp (AppT a b) = "(AppT " ++ disp a ++ " " ++ disp b ++ ")"-        disp (VarT a) = "(VarT (mkName " ++ show (show a) ++ "))"-        disp (ConT a) = "(ConT (mkName " ++ show (show a) ++ "))"----instance Guess Dec where-    guessEnv (InstanceD ctx typ inner) =-            [ (None, \e -> InstanceD ctx typ (gen e), prefix ++ str)-            | (None,gen,str) <- guessEnv inner]-        where-            principle = head (everything (++) ([] `mkQ` f) typ ++ [VarT $ mkName "?"])-                where-                    f (AppT (ConT x) y) | show x == "DataName" = [y]-                    f _ = []-            -            prefix = "InstanceD " ++-                     "(concat (" ++ list (map (guessType principle) ctx) ++ ")) " ++-                     "(head " ++ guessType principle typ ++ ")"--    guessEnv (FunD name claus) = guessPairEnv FunD "FunD" name claus-    guessEnv (ValD pat bod whr) = guessTripEnv ValD "ValD" pat bod whr-    -    guessEnv x = error $ show ("Guess Dec",x)---instance Guess Name where-    guessEnv name = if null guessCtor then guessRest else guessCtor-        where-            sname = show name-            (pre,end) = (init sname, last sname)-            -            guessCtor = [(Ctor i, \(Ctor e) -> mkName (pre ++ (ctorNames !! e))-                                ,"(mkName (" ++ show pre ++ " ++ ctorName ctor))")-                        | (i,nam) <- zip [0..] ctorNames, nam `isSuffixOf` sname-                        , let pre = take (length sname - length nam) sname]--            guessRest = guessLast ++ guessDefault-            -            guessLast | isDigit end = [(e, \e -> mkName $ pre ++ show (g e)-                                       ,"(mkName (" ++ show pre ++ " ++ show " ++ s ++ "))")-                                      | (e,g,s) <- guessNum $ read [end]]-                      | otherwise   = []--            guessDefault = [(None,const name, "(mkName " ++ show sname ++ ")")-                           | not (isDigit end) || pre `notElem` ["x","y","z"]]---guessNum :: Int -> [(Env, Env -> Int, String)]-guessNum i = [(Field i, fromField, "field") | i `elem` [1,2]] ++-             [(None, const 3, "(toInteger (length (dataCtors dat) - 1))") | i == 3] ++-             [(None, const 4, "(toInteger (length (dataCtors dat)))") | i == 4] ++-             [(Ctor i, fromCtor, "ctorInd") | i `elem` [0..3]] ++-             [(Ctor i, ctorArityEnv, "(ctorArity ctor)") | i `elem` [0..2]] ++-             [(Ctor 3, ctorArityEnv, "(ctorArity ctor)") | i == 2]----instance Guess Clause where-    guessEnv (Clause pat bod whr) = guessTripEnv Clause "Clause" pat bod whr---instance Guess Stmt where-    guessEnv (BindS x y) = guessPairEnv BindS "BindS" x y-    guessEnv (NoBindS x) = guessOneEnv NoBindS "NoBindS" x-    guessEnv x = error $ show ("Guess Stmt",x)---instance Guess Pat where-    guessEnv (VarP x) = guessOneEnv VarP "VarP" x-    guessEnv (ConP x xs) = guessPairEnv ConP "ConP" x xs-    guessEnv (WildP) = [(None, const WildP, "WildP")]-    guessEnv (TildeP x) = guessOneEnv TildeP "TildeP" x-    guessEnv (RecP x []) = guessOneEnv (flip RecP []) "(flip RecP [])" x-    guessEnv (LitP x) = guessOneEnv LitP "LitP" x-    guessEnv x = error $ show ("Guess Pat",x)---instance Guess Body where-    guessEnv (NormalB x) = guessOneEnv NormalB "NormalB" x-    guessEnv x = error $ show ("Guess Body",x)---instance Guess Exp where-    guessEnv (VarE x) = guessOneEnv VarE "VarE" x-    guessEnv (ConE x) = guessOneEnv ConE "ConE" x-    guessEnv (LitE x) = guessOneEnv LitE "LitE" x-    guessEnv (ListE x) = guessOneEnv ListE "ListE" x-    guessEnv (LamE x y) = guessPairEnv LamE "LamE" x y-    guessEnv (CompE x) = guessOneEnv CompE "CompE" x-    guessEnv (CaseE x y) = guessPairEnv CaseE "CaseE" x y-    guessEnv (TupE x) = guessOneEnv TupE "TupE" x-    guessEnv (RecConE x []) = guessOneEnv (flip RecConE []) "(flip RecConE [])" x-    guessEnv (CondE x y z) = guessTripEnv CondE "CondE" x y z-    guessEnv (DoE x) = guessOneEnv DoE "DoE" x--    guessEnv o@(AppE x y) = guessApply o ++ guessFold o ++ guessPairEnv AppE "AppE" x y-    -    guessEnv x = error $ show ("Guess Exp",x)---instance Guess Match where-    guessEnv (Match a b c) = guessTripEnv Match "Match" a b c---instance Guess Lit where-    guessEnv o@(IntegerL i) =-        [ (env, \e -> IntegerL $ toInteger $ gen e, "(IntegerL " ++ str ++ ")")-        | (env,gen,str) <- guessNum $ fromInteger i] ++-        [(None,const $ IntegerL i,"(IntegerL " ++ show i ++ ")")]-    -    guessEnv o@(StringL s) | s == "DataName" = [(None, const o, "(StringL (dataName dat))")]-                           | otherwise = [(None, const o, "(StringL " ++ show s ++ ")")]-    -    guessEnv x = error $ show ("Guess Lit",x)----- for when an expression is just an application-guessApply :: Exp -> [(Env, Env -> Exp, String)]-guessApply o | length args <= 1 = []-             | otherwise = guessPairEnv applyWith "applyWith" fn args-    where-        (fn,args) = list o-    -        list (AppE x y) = let (fn,args) = list x in (fn, args ++ [y])-        list x = (x, [])----- for when an expression comes from folding-guessFold :: Exp -> [(Env, Env -> Exp, String)]-guessFold o@(AppE (AppE fn x) y) =-        f (with foldl1With) "foldl1With" (list True  o) ++-        f (with foldr1With) "foldr1With" (list False o)-    where-        with fold join [] = VarE $ mkName "?"-        with fold join xs = fold join xs-    -        list b (AppE (AppE fn2 x) y) | fn == fn2 =-            if b then x : list b y else y : list b x-        list b x = [x]--        f ffold sfold lst-            | length lst <= 2 = []-            | otherwise = guessPairEnv ffold sfold fn lst--guessFold _ = []-

@@ -5,48 +5,40 @@ -- @ --   data Foo = Foo ; $( derive makeEq ''Foo ) -- @-module Data.DeriveTH-       (derive, deriveFromDec,-        -- * Convienience re-exports-        Derivation, -- abstract!-        module Data.Derive.All,-        -- * Internal-        _derive_string_instance-       ) where+module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where  import Data.List-import Control.Monad (liftM)+import Control.Monad  import Data.Derive.All-import Language.Haskell.TH.All-+import Data.Derive.Internal.Derivation+import Language.Haskell.TH.All as TH hiding (Derivation,toName)+import Language.Haskell as HS+import Language.Haskell.Convert  -- | Derive an instance of some class. @derive@ only derives instances -- for the type of the argument.-derive :: Derivation -> Name -> Q [Dec]-derive (Derivation f _) nm = f =<< deriveOne nm+derive :: Derivation -> TH.Name -> Q [Dec]+derive d name = do+    x <- reify name+    case x of+        TyConI dec -> deriveFromDec d dec+        _ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x ++derives :: [Derivation] -> [TH.Name] -> Q [Dec]+derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]++ -- | Derive an instance of some class. @deriveFromDec@ only derives instances -- for the type of the argument. deriveFromDec :: Derivation -> Dec -> Q [Dec]-deriveFromDec (Derivation f _) dec = f =<< fromTyConDecl dec+deriveFromDec d x = do+    x <- liftM normData $ expandData x+    case derivationOp d $ toFullDataDecl x of+        Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []+        Right v -> return $ convert v --- | Derive for a type and print the code to standard output.  This is--- a internal hook for the use of the Derive executable.-_derive_string_instance :: Derivation -> Name -> Q Exp-_derive_string_instance (Derivation f s) nm =-    return . LitE . StringL . blankLine . show . ppr . peephole =<< f =<< deriveOne nm-    where-        blankLine "" = "-- Cannot derive " ++ s ++ " for " ++ show nm-        blankLine xs = xs-     --- | Extract a 'DataDef' value from a type using the TH 'reify'--- framework.-deriveOne :: Name -> Q DataDef-deriveOne x = extract =<< reify x--fromTyConDecl = liftM normData . expandData--extract (TyConI decl) = fromTyConDecl decl-extract _ = error $ "Data.Derive.TH.deriveInternal: not a type!"+toFullDataDecl :: Dec -> FullDataDecl+toFullDataDecl x = (ModuleName "Todo", convert x)

@@ -1,200 +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' and similair classes, as discussed on the Haskell-prime mailing list:--- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.
-module Data.DeriveTraversal(-        TraveralType(..), defaultTraversalType,-        traversalDerivation1,-        traversalInstance, traversalInstance1,-        deriveTraversal-    ) where--import Language.Haskell.TH.All-import Language.Haskell.TH.Helper ( toName )-import Data.List-import qualified Data.Set as S-import Control.Monad.Writer-import Control.Applicative-------------------------------------------------------------------------------------- Stuff that should be in a library
--instance Monoid w => Applicative (Writer w) where-      pure = return-      (<*>) = ap-----------------------------------------------------------------------------------
--- Information datatype, public interface
-
--- | An expression representing a traversal of a subpart of the data
-type Trav = Exp
-
--- | What kind of traversal are we deriving?
-data TraveralType nm = TraveralType
-        { traversalArg    :: Int                     -- ^ On what position are we traversing?
-        , traversalCo     :: Bool                    -- ^ covariant?
-        , traversalName   :: nm                      -- ^ name of the traversal function
-        , traversalId     :: Trav                    -- ^ Identity traversal
-        , traversalDirect :: Trav                    -- ^ Traversal of 'a'
-        , traversalFunc   :: Name -> Trav -> Trav    -- ^ Apply the sub-traversal function
-        , traversalPlus   :: Trav -> Trav -> Trav    -- ^ Apply two non-identity traversals in sequence
-        , traverseArrow   :: 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 -> Clause    -- ^ Construct a clause of the traversal function
-        }
--defaultTraversalType = TraveralType-        { traversalArg    = 1-        , traversalCo     = False-        , traversalName   = undefined -- prevent warnings-        , traversalId     = id'-        , traversalDirect = l0 "_f"-        , traversalFunc   = l1-        , traversalPlus   = (.:)-        , traverseArrow   = fail "Cannot derive traversal over function types"-        , traverseTuple   = TupE-        , traverseCtor    = lK-        , traverseFunc    = undefined-        }--data RequiredInstance = RequiredInstance-        { requiredDataArg  :: Name -- ^ What argument of the current data type?-        , requiredPosition :: Int  -- ^ What argument position of that type?-        }-      deriving (Eq, Ord)---- | Monad that collects required instances-type WithInstances a = Writer (S.Set RequiredInstance) a--------------------------------------------------------------------------------------- Deriving traversals
----- | Derivation for a Traversable like class with just 1 method-traversalDerivation1 :: NameLike nm => TraveralType nm -> String -> Derivation-traversalDerivation1 tt nm = derivation (traversalInstance1 tt nm) (className (traversalArg tt))-    where className n = nm ++ (if n > 1 then show n else "")----- | Instance for a Traversable like class with just 1 method-traversalInstance1 :: NameLike nm => TraveralType nm -> String -> DataDef -> [Dec]-traversalInstance1 tt nm dat = traversalInstance tt nm dat [deriveTraversal tt dat]---- | Instance for a Traversable like class-traversalInstance :: NameLike nm-                  => TraveralType nm -> String -> DataDef -> [WithInstances Dec] -> [Dec]-traversalInstance tt nameBase dat bodyM- | dataArity dat == 0 = []- | otherwise          = [InstanceD ctx head body]-    where-        (body, required) = runWriter (sequence bodyM)-        ctx  = [ lK (className p) (VarT n : vars 's' (p - 1))-               | RequiredInstance n p <- S.toList required-               ]-        vrs  = vars 't' (dataArity dat)-        (vrsBefore,(_:vrsAfter)) = splitAt (length vrs - traversalArg tt) vrs-        className n = nameBase ++ (if n > 1 then show n else "")-        head = lK (className (traversalArg tt)) (lK (dataName dat) vrsBefore : vrsAfter)----- | Derive a 'traverse' like function-deriveTraversal :: NameLike nm => TraveralType nm -> DataDef -> WithInstances Dec-deriveTraversal tt dat  =  fun-    where-        fun  = funN (nameBase $ toName $ traversalNameN tt (traversalArg tt)) <$> body-        args = argPositions dat-        body = mapM (deriveTraversalCtor tt args) (dataCtors dat)----- | Derive a clause of a 'traverse' like function for a constructor-deriveTraversalCtor :: NameLike nm-                    => TraveralType nm -> ArgPositions -> CtorDef -> WithInstances Clause-deriveTraversalCtor tt ap ctor = do-        tTypes <- mapM (deriveTraversalType tt ap) (ctorTypes ctor)-        return $ traverseFunc tt (ctp ctor 'a')-               $ traverseCtor tt (ctorName ctor) (zipWith AppE tTypes (ctv ctor 'a'))----- | Derive a traversal for a type-deriveTraversalType :: NameLike nm-                    => TraveralType nm -> ArgPositions -> Type -> WithInstances Trav-deriveTraversalType tt ap (ForallT _ _ _)  = fail "forall not supported in traversal deriving"-deriveTraversalType tt ap (AppT (AppT ArrowT a) b)-                                           = traverseArrow tt <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a-                                                              <*> deriveTraversalType tt                                     ap b-deriveTraversalType tt ap (AppT a b)       = deriveTraversalApp tt ap a [b] -- T a b c ...-deriveTraversalType tt ap ListT            = return $ traversalId tt -- []-deriveTraversalType tt ap (ConT n)         = return $ traversalId tt -- T-deriveTraversalType tt ap (VarT 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 :: NameLike nm-  => TraveralType nm -> ArgPositions -> Type -> [Type] -> WithInstances Trav-deriveTraversalApp tt ap (AppT a b) args = deriveTraversalApp tt ap a (b : args)-deriveTraversalApp tt ap tycon args-  | isTupleT tycon = do -- (a,b,c)-         tArgs <- mapM (deriveTraversalType tt ap) args-         return $-           if (all (== traversalId tt) tArgs) then-             traversalId tt-           else-             LamE [TupP                                  (vars 't' (length args))]-                  (traverseTuple tt $ zipWith AppE tArgs (vars 't' (length args)))-  | otherwise = do -- T a b c-         tCon  <- deriveTraversalType tt ap tycon-         tArgs <- mapM (deriveTraversalType tt ap) args-         -- need instances?-         case tycon of-           VarT n | ap n == traversalArg tt -> fail "kind error: type used type constructor"-                  | otherwise               -> tell $ S.fromList-                                                [ RequiredInstance n i-                                                | (t,i) <- zip (reverse tArgs) [1..]-                                                , t /= traversalId tt-                                                ]-           _ -> return ()-         -- combine non-id traversals-         let nonId = [ traverseArg tt i t-                     | (t,i) <- zip (reverse tArgs) [1..]-                     , t /= traversalId tt-                     ]-         return $ case nonId of-           [] -> traversalId tt -- no interesting arguments to type con-           _  -> foldl1 (traversalPlus tt) nonId----- | Lift a traversal to the argument of a type constructor-traverseArg :: NameLike nm => TraveralType nm -> Int -> Trav -> Trav-traverseArg tt n e   =  traversalFunc tt (traversalNameN tt n) e--traversalNameN :: NameLike nm => TraveralType nm -> Int -> Name-traversalNameN tt n | n <= 1    = nm-                    | otherwise = mkName (nameBase nm ++ (if n > 1 then show n else ""))-  where nm = toName (traversalName tt)---- | Information on argument positions-type ArgPositions = Name -> Int---- | Position of an argument in the data type---   In the type  "data X a b c"---   positions are: a -> 3, b -> 2, c -> 1-argPositions :: DataDef -> Name -> Int-argPositions dat = \nm -> case elemIndex nm args of-    Nothing -> error "impossible: tyvar not in scope"-    Just k  -> length args - k- where args = ex_args dat

@@ -1,321 +0,0 @@-module Main(main) where--import System.Console.GetOpt-import System.Environment-import System.Directory-import System.Exit-import System.Cmd-import System.FilePath-import System.Random-import System.IO-import Control.Monad-import Data.Maybe-import Data.List-import Data.Char-import Data.Int---{--WHAT TO DERIVE:--To derive something we must write:--data Foo = Foo-    deriving (Eq, Ord {-! Functor, Binary !-} )--Or if we don't want to derive other stuff:--data Foo = Foo-    deriving ({-! Binary !-})--The (brackets) must be present, commas in derive list are required only to separate elements, but are permitted before or after.--CONSOLE OPTIONS:---o file, which file should the code go in - no file defaults to the console---import, should an import statement be added---import-derivation, additional modules providing derivations---module name, should a module statement be added, and if so with what name---append, append the code to the current file (overrides all other flags)--And a list of files to execute upon---}----data Flag = Version | Help | Output String | Import String | Module String | Use String-          | Append | Derive [String] | KeepTemp | NoOpts-            deriving (Eq, Show)---options :: [OptDescr Flag]-options =- [ Option "v"  ["version"] (NoArg Version)          "show version number"- , Option "h?" ["help"]    (NoArg Help)             "show help message"- , Option "o"  ["output"]  (ReqArg Output "FILE")   "output FILE"- , Option "i"  ["import"]  (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"- , Option "u"  ["use"]  (ReqArg Use "MODULE") "use additional derivations"- , Option "m"  ["module"]  (ReqArg Module "MODULE") "add a module MODULE where statement"- , Option "a"  ["append"]  (NoArg Append)           "append the result to the file"- , Option "d"  ["derive"]  (ReqArg splt "DERIVES") "things to derive for all types"- , Option "k"  ["keep"]    (NoArg KeepTemp)         "keep temporary file"- , Option "n"  ["no-opts"] (NoArg NoOpts)           "ignore the file options"- ]- where-    splt = Derive . words . map (\x -> if x == ',' then ' ' else x)---getOpts :: IO ([Flag], [String])-getOpts = do-    args <- getArgs-    case getOpt Permute options args of-        (o,n,[]  ) | Version `elem` o -> putStrLn "Derive 0.1, (C) Neil Mitchell & Stefan O'Rear 2006-2008" >> exitSuccess-                   | Help `elem` o    -> putStr useage >> exitSuccess-                   | null n           -> putStr ("no files specified\n" ++ useage) >> exitSuccess-                   | otherwise        -> return (o, n)-        (_,_,errs) -> hPutStr stderr (concat errs ++ useage) >> exitFailure-    where-        useage = usageInfo "Usage: derive [OPTION...] files..." options-        exitSuccess = exitWith ExitSuccess--main :: IO ()-main = do-    (flags,files) <- getOpts-    fles <- mapM pickFile files-    mapM_ (mainFile flags) (catMaybes fles)-    when (any isNothing fles) exitFailure---pickFile :: FilePath -> IO (Maybe FilePath)-pickFile orig = f [orig, orig <.> "hs", orig <.> "lhs"]-    where-        f [] = hPutStrLn stderr ("Error, file not found: " ++ orig) >> return Nothing-        f (x:xs) = do-            b <- doesFileExist x-            if b then return $ Just x else f xs--appendMsg :: String-appendMsg = "--------------------------------------------------------\n" ++-            "-- DERIVES GENERATED CODE\n" ++-            "-- DO NOT MODIFY BELOW THIS LINE\n" ++-            "-- CHECKSUM: "----- delete the end of a file with the appendMsg and a correct hash--- make sure there are at least 4 blank lines at the end--- return True for warning-dropAppend :: String -> (String,Bool)-dropAppend xs = f 0 xs-    where-        f i ys | appendMsg `isPrefixOf` ys =-                if hashString (filter (/= '\r') rest) == chk-                then f i []-                else (ys ++ "\n\n\n\n", True)-            where (chk, rest) = span isDigit $ drop (length appendMsg) ys--        f i [] = (replicate (4 - i) '\n', False)-        f i ('\n':ys) = add '\n' (f (i+1) ys)-        f _ (y:ys) = add y (f 0 ys)--        add c ~(cs,b) = (c:cs,b)----- note: need to be careful that on Windows we don't convert \n files into---       \r\n files-mainFile :: [Flag] -> FilePath -> IO ()-mainFile flags file = do-    file <- canonicalizePath file-    (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file-    let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"-               | (ctor,cls) <- reqs]--    let hscode x = "{-# OPTIONS_GHC -fth -fglasgow-exts -w #-}\n" ++-                   unlines pragmas ++-                   "module " ++ modname ++ " where\n" ++-                   "import Data.DeriveTH\n" ++-                   "import Data.Derive.All\n" ++-                   concat [ "import " ++ x ++ "\n" | Use x <- flags ] ++-                   datas ++ "\n" ++-                   "main = Prelude.writeFile " ++ show x ++ " $\n" ++-                   "    Prelude.unlines [" ++ concat (intersperse ", " devs) ++ "]\n"--    -- note: Wrong on Hugs on Windows-    tmpdir <- getTemporaryDirectory-    b <- doesDirectoryExist tmpdir-    tmpdr <- return $ if b && KeepTemp `notElem` flags then tmpdir else ""--    (hsfile, hshndl) <- openTempFileLocal tmpdr "Temp.hs"-    (txfile, txhndl) <- openTempFileLocal tmpdr "Temp.txt"-    hClose txhndl--    hPutStr hshndl $ hscode txfile-    hClose hshndl--    let incdir = dropTrailingPathSeparator $ joinPath $ reverse $-                 drop (1 + length (filter (== '.') modname)) $ reverse $ splitPath file-        cmd = "ghc -w -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile-    code <- system cmd-    when (code /= ExitSuccess) $ do-        putStrLn "Failed to generate the code"-        exitWith code--    res <- readFile' txfile-    when (KeepTemp `notElem` flags) $ do-        removeFile hsfile-        removeFile txfile--    flgs <- return $ fileflags ++ flags-    if Append `elem` flgs then do-        src <- readFileBinary file-        let (src2,c) = dropAppend src-            ans = (if '\r' `elem` src then windowsNewLine else id)-                  (src2 ++ if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res)-        when c $ putStrLn "Warning, Checksum does not match, please edit the file manually"-        writeFileBinary file ans-     else do-        let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flgs]-            impline = unlines ["import " ++ if null i then modname else i | Import i <- flgs]-            answer = modline ++ impline ++ res--        case [x | Output x <- flgs] of-             [] -> putStr answer-             (x:_) -> writeFile x answer----- return the flags, a string that is the data structures only (including Typeable, Data)--- and a set of derivation names with types---- first disguard blank lines and lines which are -- comments--- next find all lines which start a section, i.e. have something in column 0--- group lines so every line starts at column 1--- look for newtype, data etc.--- look for deriving-parseFile :: [Flag] -> FilePath -> IO ([Flag], [String], String, String, [(String,String)])-parseFile flags file = do-        src <- liftM lines $ readFile file-        optns <- if NoOpts `elem` flags then return [] else parseOptions src-        pragmas <- return $ parsePragmas src-        modname <- parseModname src-        let deriv = concat [x | Derive x <- flags ++ optns]-        (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $-                               map dropComments $ filter (not . isBlank) src-        return (optns, pragmas, modname, unlines decl, concat req)-    where-        parsePragmas (x:xs)-            | "{-#" `isPrefixOf` x2 && "#-}" `isSuffixOf` x2 = x2 : parsePragmas xs-            | null x2 = parsePragmas xs-            where x2 = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace x-        parsePragmas _ = []--        parseOptions (x:xs)-            | "{-# OPTIONS_DERIVE " `isPrefixOf` x = do-                    a <- readOptions $ takeWhile (/= '#') $ drop 19 x-                    b <- parseOptions xs-                    return $ a ++ b-            | "{-# OPTIONS" `isPrefixOf` x = parseOptions xs-        parseOptions _ = return []--        readOptions x = case getOpt Permute options (words x) of-                            (a,_,ns) -> mapM_ putStr ns >> return a---        parseModname (x:_) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x-            where f y = not (isSpace y) && y `notElem` "("-        parseModname (_:ys) = parseModname ys-        parseModname [] = putStrLn "Error, module name not detected" >> return "Main"---        isBlank x = null x2 || "--" `isPrefixOf` x2-            where x2 = dropWhile isSpace x--        dropComments ('-':'-':_) = []-        dropComments (x:xs) = x : dropComments xs-        dropComments [] = []--        joinLines (x1:x2:xs) | col1 x1 && not (col1 x2) = joinLines ((x1 ++ x2) : xs)-            where col1 = null . takeWhile isSpace-        joinLines (x:xs) = x : joinLines xs-        joinLines [] = []--        checkData extra x-                | keyword `elem` ["data","newtype"] = [(x, map ((,) name) req)]-                | keyword `elem` ["type","import"] = [(x,[])]-                | otherwise = []-            where-                keyword = takeWhile (not . isSpace) x-                name = parseName $ drop (length keyword) x-                req = nub $ extra ++ parseDeriving x---        -- which derivings have been requested-        -- find all things inside {-! !-} and 'words' them-        parseDeriving :: String -> [String]-        parseDeriving x = words $ f False x-            where-                f _ ('{':'-':'!':xs) = ' ' : f True  xs-                f _ ('!':'-':'}':xs) = ' ' : f False xs-                f b (y:ys) = [if y == ',' then ' ' else y | b] ++ f b ys-                f _ [] = []---        -- if there is a =>, its just after that-        -- if there isn't, then its right now-        -- if the => is after =, then ignore-        parseName x = if "=>" `isPrefixOf` b-                      then parseName (drop 2 b)-                      else head (words a)-            where (a,b) = break (== '=') x---hashString :: String -> String-hashString = show . abs . foldl f 0 . filter (not . isSpace)-    where-        f :: Int32 -> Char -> Int32-        f x y = x * 31 + fromIntegral (ord y)----- Note: openTempFile is not available on Hugs, which sucks-openTempFileLocal :: FilePath -> String -> IO (FilePath, Handle)-openTempFileLocal dir template = do-    i <- randomRIO (1000::Int,9999)-    let (file,ext) = splitExtension template-        s = dir </> (file ++ show i) <.> ext-    b <- doesFileExist s-    if b then openTempFileLocal dir template else do-        h <- openFile s ReadWriteMode-        return (s, h)---readFile' :: FilePath -> IO String-readFile' file = do-    h <- openFile file ReadMode-    res <- hGetContents h-    length res `seq` return ()-    hClose h-    return res---readFileBinary :: FilePath -> IO String-readFileBinary file = do-    h <- openBinaryFile file ReadMode-    hGetContents h---writeFileBinary :: FilePath -> String -> IO ()-writeFileBinary file s = do-    h <- openBinaryFile file WriteMode-    hPutStr h s-    hClose h---windowsNewLine :: String -> String-windowsNewLine ('\r':'\n':xs) = '\r':'\n': windowsNewLine xs-windowsNewLine ('\n':xs) = '\r':'\n': windowsNewLine xs-windowsNewLine (x:xs) = x : windowsNewLine xs-windowsNewLine [] = []-

@@ -0,0 +1,382 @@++module Derive.Derivation(wantDerive, performDerive, writeDerive) where++import System.IO+import System.IO.Unsafe+import Language.Haskell+import Control.Monad+import Data.List+import Derive.Utils+import Derive.Flags+import Data.Derive.All+import Data.Derive.Internal.Derivation+++---------------------------------------------------------------------+-- WHAT DO YOU WANT TO DERIVE++wantDerive :: [Flag] -> (String, Module) -> [(String, DataDecl)]+wantDerive flag (str,modu) = nub $ wantDeriveFlag flag decls ++ wantDeriveAnnotation str decls+    where decls = filter isDataDecl $ moduleDecls modu+++wantDeriveFlag :: [Flag] -> [DataDecl] -> [(String, DataDecl)]+wantDeriveFlag flags decls = [(x, d) | Derive xs <- flags, x <- xs, d <- decls]+++-- find annotations by looking for {-! !-} parts, and matching up the source loc+wantDeriveAnnotation :: String -> [DataDecl] -> [(String, DataDecl)]+wantDeriveAnnotation src decls = [(d, decl) | (pos, ds) <- annotations, let decl = match pos, d <- ds]+    where+        annotations :: [((Int,Int), [String])]+        annotations = [((i,j),parse xs) | (i,s) <- zip [1..] $ lines src, (j,'{':'-':'!':xs) <- zip [1..] $ tails s]+        +        parse :: String -> [String]+        parse = words . reps ',' ' ' . closeComment++        closeComment ('!':'-':'}':xs) = ""+        closeComment ('-':'}':xs) = ""+        closeComment (x:xs) = x : closeComment xs+        closeComment [] = ""+        +        match :: (Int,Int) -> DataDecl+        match p = head [d | d <- reverse decls, let sl = dataDeclSrcLoc d, (srcLine sl, srcColumn sl) < p]+++---------------------------------------------------------------------+-- ACTUALLY DERIVE IT++performDerive :: ModuleName -> [(String, DataDecl)] -> [String]+performDerive modu = concatMap ((:) "" . f)+    where+        f (name,dat) =+            case d (modu,dat) of+                Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]+                Right x -> concatMap (lines . prettyPrint) x+            where d = head $ [op | Derivation n op <- derivations, n == name] ++ +                             error (msg "Unknown derivation")+                  msg x = "Deriving " ++ name ++ " for " ++ dataDeclName dat ++ ": " ++ x+++---------------------------------------------------------------------+-- WRITE IT BACK++writeDerive :: FilePath -> ModuleName -> [Flag] -> [String] -> IO ()+writeDerive file modu flags xs = do+    -- force the output first, ensure that we don't crash half way through+    () <- length (concat xs) `seq` return ()+    +    let append = Append `elem` flags+    let output = [x | Output x <- flags]++    let pre = take 1 ["module " ++ x ++ " where" | Modu x <- flags] +++              ["import " ++ if null i then prettyPrint modu else i | Import i <- flags]++    when append $ do+        src <- readFile' file+        writeGenerated file xs++    forM output $ \o ->+        writeFile o $ unlines $ pre ++ xs++    when (not append && null output) $+        putStr $ unlines xs++++{-+++++++++import System.Console.GetOpt+import System.Environment+import System.Directory+import System.Exit+import System.Cmd+import System.FilePath+import System.Random+import System.IO+import Control.Monad+import Data.Maybe+import Data.List+import Data.Char+import Data.Int+++data Flag = Version | Help | Output String | Import String | Module String | Use String+          | Append | Derive [String] | KeepTemp | NoOpts+            deriving (Eq, Show)+++options :: [OptDescr Flag]+options =+ [ Option "v"  ["version"] (NoArg Version)          "show version number"+ , Option "h?" ["help"]    (NoArg Help)             "show help message"+ , Option "o"  ["output"]  (ReqArg Output "FILE")   "output FILE"+ , Option "i"  ["import"]  (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"+ , Option "u"  ["use"]  (ReqArg Use "MODULE") "use additional derivations"+ , Option "m"  ["module"]  (ReqArg Module "MODULE") "add a module MODULE where statement"+ , Option "a"  ["append"]  (NoArg Append)           "append the result to the file"+ , Option "d"  ["derive"]  (ReqArg splt "DERIVES") "things to derive for all types"+ , Option "k"  ["keep"]    (NoArg KeepTemp)         "keep temporary file"+ , Option "n"  ["no-opts"] (NoArg NoOpts)           "ignore the file options"+ ]+ where+    splt = Derive . words . map (\x -> if x == ',' then ' ' else x)+++getOpts :: IO ([Flag], [String])+getOpts = do+    args <- getArgs+    case getOpt Permute options args of+        (o,n,[]  ) | Version `elem` o -> putStrLn "Derive 0.1, (C) Neil Mitchell & Stefan O'Rear 2006-2008" >> exitSuccess+                   | Help `elem` o    -> putStr useage >> exitSuccess+                   | null n           -> putStr ("no files specified\n" ++ useage) >> exitSuccess+                   | otherwise        -> return (o, n)+        (_,_,errs) -> hPutStr stderr (concat errs ++ useage) >> exitFailure+    where+        useage = usageInfo "Usage: derive [OPTION...] files..." options+        exitSuccess = exitWith ExitSuccess++main :: IO ()+main = do+    (flags,files) <- getOpts+    fles <- mapM pickFile files+    mapM_ (mainFile flags) (catMaybes fles)+    when (any isNothing fles) exitFailure+++pickFile :: FilePath -> IO (Maybe FilePath)+pickFile orig = f [orig, orig <.> "hs", orig <.> "lhs"]+    where+        f [] = hPutStrLn stderr ("Error, file not found: " ++ orig) >> return Nothing+        f (x:xs) = do+            b <- doesFileExist x+            if b then return $ Just x else f xs++appendMsg :: String+appendMsg = "--------------------------------------------------------\n" +++            "-- DERIVES GENERATED CODE\n" +++            "-- DO NOT MODIFY BELOW THIS LINE\n" +++            "-- CHECKSUM: "+++-- delete the end of a file with the appendMsg and a correct hash+-- make sure there are at least 4 blank lines at the end+-- return True for warning+dropAppend :: String -> (String,Bool)+dropAppend xs = f 0 xs+    where+        f i ys | appendMsg `isPrefixOf` ys =+                if hashString (filter (/= '\r') rest) == chk+                then f i []+                else (ys ++ "\n\n\n\n", True)+            where (chk, rest) = span isDigit $ drop (length appendMsg) ys++        f i [] = (replicate (4 - i) '\n', False)+        f i ('\n':ys) = add '\n' (f (i+1) ys)+        f _ (y:ys) = add y (f 0 ys)++        add c ~(cs,b) = (c:cs,b)+++-- note: need to be careful that on Windows we don't convert \n files into+--       \r\n files+mainFile :: [Flag] -> FilePath -> IO ()+mainFile flags file = do+    file <- canonicalizePath file+    (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file+    let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"+               | (ctor,cls) <- reqs]++    let hscode x = "{ -# OPTIONS_GHC -fth -fglasgow-exts -w #- }\n" +++                   unlines pragmas +++                   "module " ++ modname ++ " where\n" +++                   "import Data.DeriveTH\n" +++                   "import Data.Derive.All\n" +++                   concat [ "import " ++ x ++ "\n" | Use x <- flags ] +++                   datas ++ "\n" +++                   "main = Prelude.writeFile " ++ show x ++ " $\n" +++                   "    Prelude.unlines [" ++ concat (intersperse ", " devs) ++ "]\n"++    -- note: Wrong on Hugs on Windows+    tmpdir <- getTemporaryDirectory+    b <- doesDirectoryExist tmpdir+    tmpdr <- return $ if b && KeepTemp `notElem` flags then tmpdir else ""++    (hsfile, hshndl) <- openTempFileLocal tmpdr "Temp.hs"+    (txfile, txhndl) <- openTempFileLocal tmpdr "Temp.txt"+    hClose txhndl++    hPutStr hshndl $ hscode txfile+    hClose hshndl++    let incdir = dropTrailingPathSeparator $ joinPath $ reverse $+                 drop (1 + length (filter (== '.') modname)) $ reverse $ splitPath file+        cmd = "ghc -w -i. -i\"" ++ incdir ++ "\" -e " ++ modname ++ ".main " ++ hsfile+    code <- system cmd+    when (code /= ExitSuccess) $ do+        putStrLn "Failed to generate the code"+        exitWith code++    res <- readFile' txfile+    when (KeepTemp `notElem` flags) $ do+        removeFile hsfile+        removeFile txfile++    flgs <- return $ fileflags ++ flags+    if Append `elem` flgs then do+        src <- readFileBinary file+        let (src2,c) = dropAppend src+            ans = (if '\r' `elem` src then windowsNewLine else id)+                  (src2 ++ if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res)+        when c $ putStrLn "Warning, Checksum does not match, please edit the file manually"+        writeFileBinary file ans+     else do+        let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flgs]+            impline = unlines ["import " ++ if null i then modname else i | Import i <- flgs]+            answer = modline ++ impline ++ res++        case [x | Output x <- flgs] of+             [] -> putStr answer+             (x:_) -> writeFile x answer+++-- return the flags, a string that is the data structures only (including Typeable, Data)+-- and a set of derivation names with types++-- first disguard blank lines and lines which are -- comments+-- next find all lines which start a section, i.e. have something in column 0+-- group lines so every line starts at column 1+-- look for newtype, data etc.+-- look for deriving+parseFile :: [Flag] -> FilePath -> IO ([Flag], [String], String, String, [(String,String)])+parseFile flags file = do+        src <- liftM lines $ readFile file+        optns <- if NoOpts `elem` flags then return [] else parseOptions src+        pragmas <- return $ parsePragmas src+        modname <- parseModname src+        let deriv = concat [x | Derive x <- flags ++ optns]+        (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $+                               map dropComments $ filter (not . isBlank) src+        return (optns, pragmas, modname, unlines decl, concat req)+    where+        parsePragmas (x:xs)+            | "{ -#" `isPrefixOf` x2 && "#- }" `isSuffixOf` x2 = x2 : parsePragmas xs+            | null x2 = parsePragmas xs+            where x2 = reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace x+        parsePragmas _ = []++        parseOptions (x:xs)+            | "{ -# OPTIONS_DERIVE " `isPrefixOf` x = do+                    a <- readOptions $ takeWhile (/= '#') $ drop 19 x+                    b <- parseOptions xs+                    return $ a ++ b+            | "{ -# OPTIONS" `isPrefixOf` x = parseOptions xs+        parseOptions _ = return []++        readOptions x = case getOpt Permute options (words x) of+                            (a,_,ns) -> mapM_ putStr ns >> return a+++        parseModname (x:_) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x+            where f y = not (isSpace y) && y `notElem` "("+        parseModname (_:ys) = parseModname ys+        parseModname [] = putStrLn "Error, module name not detected" >> return "Main"+++        isBlank x = null x2 || "--" `isPrefixOf` x2+            where x2 = dropWhile isSpace x++        dropComments ('-':'-':_) = []+        dropComments (x:xs) = x : dropComments xs+        dropComments [] = []++        joinLines (x1:x2:xs) | col1 x1 && not (col1 x2) = joinLines ((x1 ++ x2) : xs)+            where col1 = null . takeWhile isSpace+        joinLines (x:xs) = x : joinLines xs+        joinLines [] = []++        checkData extra x+                | keyword `elem` ["data","newtype"] = [(x, map ((,) name) req)]+                | keyword `elem` ["type","import"] = [(x,[])]+                | otherwise = []+            where+                keyword = takeWhile (not . isSpace) x+                name = parseName $ drop (length keyword) x+                req = nub $ extra ++ parseDeriving x+++        -- which derivings have been requested+        -- find all things inside { -! !- } and 'words' them+        parseDeriving :: String -> [String]+        parseDeriving x = words $ f False x+            where+                f _ ('{':'-':'!':xs) = ' ' : f True  xs+                f _ ('!':'-':'}':xs) = ' ' : f False xs+                f b (y:ys) = [if y == ',' then ' ' else y | b] ++ f b ys+                f _ [] = []+++        -- if there is a =>, its just after that+        -- if there isn't, then its right now+        -- if the => is after =, then ignore+        parseName x = if "=>" `isPrefixOf` b+                      then parseName (drop 2 b)+                      else head (words a)+            where (a,b) = break (== '=') x+++hashString :: String -> String+hashString = show . abs . foldl f 0 . filter (not . isSpace)+    where+        f :: Int32 -> Char -> Int32+        f x y = x * 31 + fromIntegral (ord y)+++-- Note: openTempFile is not available on Hugs, which sucks+openTempFileLocal :: FilePath -> String -> IO (FilePath, Handle)+openTempFileLocal dir template = do+    i <- randomRIO (1000::Int,9999)+    let (file,ext) = splitExtension template+        s = dir </> (file ++ show i) <.> ext+    b <- doesFileExist s+    if b then openTempFileLocal dir template else do+        h <- openFile s ReadWriteMode+        return (s, h)+++readFile' :: FilePath -> IO String+readFile' file = do+    h <- openFile file ReadMode+    res <- hGetContents h+    length res `seq` return ()+    hClose h+    return res+++readFileBinary :: FilePath -> IO String+readFileBinary file = do+    h <- openBinaryFile file ReadMode+    hGetContents h+++writeFileBinary :: FilePath -> String -> IO ()+writeFileBinary file s = do+    h <- openBinaryFile file WriteMode+    hPutStr h s+    hClose h+++windowsNewLine :: String -> String+windowsNewLine ('\r':'\n':xs) = '\r':'\n': windowsNewLine xs+windowsNewLine ('\n':xs) = '\r':'\n': windowsNewLine xs+windowsNewLine (x:xs) = x : windowsNewLine xs+windowsNewLine [] = []++-}

@@ -0,0 +1,63 @@++module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where++import System.Environment+import System.Console.GetOpt+import System.Directory+import Language.Haskell+import System.Exit+import System.IO+import Data.Maybe+++data Flag = Version | Help | Output String | Import String | Modu String+          | Append | Derive [String] | NoOpts | Test | Generate+            deriving (Eq, Show)+++options :: [OptDescr Flag]+options =+    [Option "v"  ["version"]  (NoArg Version)          "show version number"+    ,Option "h?" ["help"]     (NoArg Help)             "show help message"+    ,Option "o"  ["output"]   (ReqArg Output "FILE")   "output FILE"+    ,Option "i"  ["import"]   (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"+    ,Option "m"  ["module"]   (ReqArg Modu "MODULE")   "add a module MODULE where statement"+    ,Option "a"  ["append"]   (NoArg Append)           "append the result to the file"+    ,Option "d"  ["derive"]   (ReqArg splt "DERIVES")  "things to derive for all types"+    ,Option "n"  ["no-opts"]  (NoArg NoOpts)           "ignore the file options"+    ,Option ""   ["test"]     (NoArg Test)             "run the test suite"+    ,Option ""   ["generate"] (NoArg Generate)         "perform code generation"+    ]+    where splt = Derive . words . map (\x -> if x == ',' then ' ' else x)+++flagInfo = usageInfo "Usage: derive [OPTION...] files..." options+++getFlags :: IO ([Flag], [String])+getFlags = do+    args <- getArgs+    case getOpt Permute options args of+        (o,n,[]  ) | Version `elem` o -> putStrLn "Derive 2.0, (C) Neil Mitchell 2006-2009" >> exitSuccess+                   | Help `elem` o    -> putStr flagInfo >> exitSuccess+                   | otherwise        -> do files <- mapM pickFile n; return (o, files)+        (_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure+    where+        exitSuccess = exitWith ExitSuccess+++pickFile :: FilePath -> IO FilePath+pickFile orig = f [orig, orig ++ ".hs", orig ++ ".lhs"]+    where+        f [] = error $ "File not found: " ++ orig+        f (x:xs) = do+            b <- doesFileExist x+            if b then return x else f xs+++addFlags :: [Flag] -> (SrcLoc, [String]) -> [Flag]+addFlags flags (sl,xs)+    | NoOpts `elem` flags = flags+    | errs /= [] = error $ prettyPrint sl ++ "\n" ++ concat errs+    | otherwise = flags ++ a+    where (a,_,errs) = getOpt Permute options xs

@@ -0,0 +1,119 @@++module Derive.Generate(generate) where++import Language.Haskell.Exts+import Data.DeriveDSL+import Derive.Utils+import Control.Monad+import Data.Maybe+import System.FilePath+import System.Directory+import Data.Char+import Data.List+++evil = words $ "PlateDirect TTypeable Uniplate"++-- generate extra information for each derivation+generate :: IO ()+generate = do+    xs <- getDirectoryContents "Data/Derive"+    xs <- return [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]+    lis <- mapM generateFile $ map ("Data/Derive" </>) xs+    let names = map dropExtension xs+        n = maximum $ map length names+    writeGenerated "Data/Derive/All.hs" $+        ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] +++        ["derivations :: [Derivation]"+        ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]+    writeGenerated "derive.htm" $ ["-->"] ++ lis ++ ["<!--"]+    writeGenerated "derive.cabal" $ map ("        Data.Derive."++) names+++-- return the Documentation string+generateFile :: FilePath -> IO String+generateFile file = do+    let name = takeBaseName file+    putStrLn $ "Generating " ++ name+    src <- readSrc file+    when (isJust $ srcExample src) $ do+        let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $+                            deriveDSL $ fromJust $ srcExample src+        writeGenerated file $+            [""+            ,"import Data.Derive.DSL.DSL"+            ,"import Data.Derive.Internal.Derivation"+            ,""+            ,"make" ++ name ++ " :: Derivation"+            ] ++ (if srcCustom src then+                ["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]+            else+                ["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name+                ,""+                ,"dsl" ++ name ++ " ="+            ]) +++            map (replicate 4 ' ' ++) (wrap 66 $ show dsl)+++        let inst = dynamicDSL dsl+            instFile = takeDirectory file </> "Instance" </> name <.> "hs"+        b <- doesFileExist instFile+        if not (srcCustom src) && isJust inst then do+            writeGenerated instFile $+                ["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] +++                ["","module Data.Derive.Instance." ++ name ++ " where",""] +++                (map prettyPrint $ srcImportStd src) +++                ["import Data.Derive.Internal.Instance",""] +++                (map prettyPrint $ fromJust inst) ++ [""]+         else when b $+            error $ "Previously generated dynamic instance can not be regenerated, " ++ name++    let imp = listToMaybe $ srcImport src+    return $ concat $+        ["<li>"+        ,"<b><a href='" ++ instUrl name imp ++ "'>" ++ name ++ "</a></b>"] +++        [" - from the library <a href='" ++ pkgUrl pkg ++ "'>" ++ pkg ++ "</a>" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp] +++        ["</li>"]++pkgUrl x = "http://hackage.haskell.org/package/" ++ x++instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"+instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam+    where+        (a,b) = break (== '-') $ fromMaybe "base" $ importPkg x+        pkgName = a+        pkgVersion = if null b then "latest" else tail b+        modu = reps '.' '-' $ prettyPrint $ importModule x+        nam = case importSpecs x of Just (False,IAbs y:_) -> prettyPrint y ; _ -> name+++wrap :: Int -> String -> [String]+wrap n = f . lexemes+    where+        f [] = []+        f (x:xs) = [reverse $ dropWhile isSpace $ reverse $ concat $ x:a] ++ f (dropWhile (all isSpace) b)+            where (a,b) = thisLine (n - length x) xs++        thisLine i [] = ([], [])+        thisLine i (x:xs) | j > i = ([], x:xs)+                          | otherwise = (x:a, b)+            where j = length x+                  (a,b) = thisLine (i - j) xs+++lexemes :: String -> [String]+lexemes [] = []+lexemes x = a : lexemes b+    where (a,b) = lexeme x +++lexeme :: String -> (String, String)+lexeme xs@(x:_) | isAlpha x = span isAlpha xs+lexeme ('\"':xs) = let (a,b) = f xs in ('\"':a,b)+    where f ('\\':x:xs) = let (a,b) = f xs in ('\\':x:a,b)+          f ('\"':xs) = ("\"",xs)+          f (x:xs) = let (a,b) = f xs in (x:a,b)+          f [] = ([],[])+lexeme (x:xs) = ([x], xs)++

@@ -0,0 +1,90 @@++module Derive.Test(test) where++import Derive.Utils+import Language.Haskell.Exts+import Data.Derive.DSL.HSE+import Data.DeriveDSL+import Control.Monad+import Data.Maybe+import Data.List+import System.FilePath+import System.Directory+import System.Cmd+import System.Exit+import Control.Arrow+import Data.Char+import Data.Derive.All+import Data.Derive.Internal.Derivation++++listType :: Decl+listType = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]+    [QualConDecl sl [] [] (ConDecl (Ident "[]") [])+    ,QualConDecl sl [] [] (ConDecl (Ident "Cons")+        [UnBangedTy (TyVar (Ident "a"))+        ,UnBangedTy (TyApp (TyCon (UnQual (Ident "List"))) (TyVar (Ident "a")))])]+    []+++-- test each derivation+test :: IO ()+test = do+    decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"++    -- check the test bits+    let ts = ("[]",listType) : map (dataDeclName &&& id) decls+    mapM_ (testFile ts) derivations++    -- check the $(derive) bits+    putStrLn "Type checking examples"+    let name = "AutoGenerated_Test.hs"+    srcs <- sequence [readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]+    writeFile name $ unlines $ autoTest srcs decls derivations+    res <- system $ "runhaskell " ++ name+    when (res /= ExitSuccess) $ error "Failed to typecheck results"+++testFile :: [(String,Decl)] -> Derivation -> IO ()+testFile types (Derivation name op) = do+    putStrLn $ "Testing " ++ name+    src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"+    forM_ (srcTest src) $ \(typ,res) -> do+        let t = fromMaybe (error $ "wanting type: " ++ typ) $ lookup typ types+        let Right r = op (ModuleName "Example", t)+        when (not $ r `outEq` res) $+            error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r++detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb+    where na = length as ; nb = length bs++detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b+    where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)+++ignore = ["ArbitraryOld","Serial","BinaryDefer","EnumCyclic","Ref","PlateTypeable","LazySet"]++autoTest :: [Src] -> [DataDecl] -> [Derivation] -> [String]+autoTest ss ts ds =+    ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses #-}"+    ,"{-# OPTIONS_GHC -fno-warn-missing-fields #-}"+    ,"import Data.DeriveTH"+    ,"import Derive.TestInstances"] +++    [prettyPrint i | s <- ss2, i <- srcImportStd s] +++    ["main = putStrLn \"Type checking successful\""] +++    [prettyPrint t | t <- ts2] +++    ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | d <- ds2]+    where+        types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"+        ts2 = filter (not . isBuiltIn) ts+        ds2 = filter (flip notElem ignore . derivationName) $ order ds+        ss2 = filter (flip notElem ignore . srcName) ss++isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]++++order :: [Derivation] -> [Derivation]+order ds = yes ++ no+    where (yes,no) = partition (flip elem ["Eq","Typeable"] . derivationName) ds

@@ -0,0 +1,87 @@++module Derive.Utils where++import Data.Derive.DSL.HSE+import Data.List+import qualified Data.ByteString.Char8 as BS+import System.Directory+import System.IO+import System.FilePath+import Control.Monad+import Data.Char+import Data.Maybe+++data Src = Src+    {srcName :: String+    ,srcImport :: [ImportDecl]+    ,srcExample :: Maybe [Decl]+    ,srcTest :: [(String,[Decl])]+    ,srcCustom :: Bool+    }++-- skip the importPkg bits+srcImportStd :: Src -> [ImportDecl]+srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]++nullSrc = Src "" [] Nothing [] False+++readHSE :: FilePath -> IO Module+readHSE file = do+    src <- readFile' file+    src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $+                    dropWhile (not . isPrefixOf "module ") $ lines src++    let mode = defaultParseMode{extensions=[MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}+    return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src+++data Pragma = Example Bool | Test String++asPragma :: Decl -> Maybe Pragma+asPragma (TypeSig _ [x] t)+    | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"+    | x ~= "test" = Just $ Test $ prettyPrint t+asPragma _ = Nothing+++readSrc :: FilePath -> IO Src+readSrc file = do+    modu <- readHSE file+    return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}+        [ (p,xs)+        | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]+        , let xs = takeWhile (isNothing . asPragma) real ]+    where+        f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}+        f src (Test    x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}+++generatedStart = "-- GENERATED START"+generatedStop  = "-- GENERATED STOP"++++writeGenerated :: FilePath -> [String] -> IO ()+writeGenerated file x = do+    src <- fmap lines $ readFile' file+    let pre = takeWhile (/= generatedStart) src+        post = drop 1 $ dropWhile (/= generatedStop) src+        src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post+    when (src /= src2) $+        seq (length src2) $ writeBinaryFile file $ unlines src2+++readFile' :: FilePath -> IO String+readFile' file = do+    b <- doesFileExist file+    if b then fmap BS.unpack $ BS.readFile file else return []+++writeBinaryFile :: FilePath -> String -> IO ()+writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)+++rep from to x = if x == from then to else x+reps from to = map (rep from to)

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

@@ -0,0 +1,242 @@++module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where++import Language.Haskell.Exts hiding (var,app,binds,paren)+import Data.List+import Data.Generics.PlateData+import Data.Data+import Data.Char+++infix 1 ?+True ? b = const b+False ? b = id++++-- insert explicit foralls+foralls :: Type -> Type+foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x+++tyApps x [] = x+tyApps x (y:ys) = tyApps (TyApp x y) ys++isTyFun TyFun{} = True+isTyFun _ = False++x ~= y = prettyPrint x == y+++appP x@App{} y = App x y+appP x y = App (paren x) (paren y)+++simplify :: Data a => a -> a+simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp+    where+        fExp (App op (List xs))+            | op ~= "length" = Lit $ Int $ fromIntegral $ length xs+            | op ~= "head" = head xs+        fExp (InfixApp (Lit (Int i)) op (Lit (Int j)))+            | op ~= "-" = Lit $ Int $ i - j+            | op ~= "+" = Lit $ Int $ i + j+            | op ~= ">" = Con $ UnQual $ Ident $ show $ i > j+        fExp (InfixApp x op y)+            | op ~= "`const`" = x+            | op ~= "&&" && y ~= "True" = x+            | x ~= "id" && op ~= "." = y+            | y ~= "id" && op ~= "." = x+        fExp (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 y) (UnGuardedAlt z) (BDecls []) <- alts, y == x]+        fExp (If x t f)+            | x ~= "True" = t+            | x ~= "False" = f+        fExp (App (App when b) x)+            | b ~= "True" = x+            | 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 x = x++        fTyp (TyApp x y) | x ~= "[]" = TyApp (TyCon (Special ListCon)) y+        fTyp (TyParen x@(TyApp (TyCon (Special ListCon)) _)) = x+        fTyp (TyParen x@TyCon{}) = x+        fTyp (TyParen x@TyVar{}) = x+        fTyp (TyCon nam) = TyCon $ rename nam+        fTyp x = x++        fPat (PParen x@(PApp _ [])) = x+        fPat (PApp nam xs) = PApp (rename nam) 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 (UnGuardedAlt y) (BDecls [])])) decls)+            | x == x2 = fMatch $ Match sl nam [PParen pat] sig (UnGuardedRhs y) decls+        fMatch (Match a b c d e bind) = fBinds (Match a b c d e) bind++        fDecl (PatBind a b c d bind) = fBinds (PatBind a b c d) bind+        fDecl (FunBind xs) = FunBind $ filter (not . isGuardFalse) xs+        fDecl x = x++        fBinds context (BDecls bind) | inline /= [] =+                simplify $ subst (Var $ UnQual from) to $ context $ BDecls $ take i bind ++ drop (i+1) bind+            where+                f (PatBind _ (PVar x) Nothing (UnGuardedRhs bod) (BDecls [])) = [(x,bod)]+                f (FunBind [Match _ x [PVar v] Nothing (UnGuardedRhs (Paren (App bod (Var v2)))) (BDecls [])])+                    | UnQual v == v2 = [(x,bod)]+                f (FunBind [Match sl x pat Nothing (UnGuardedRhs bod) (BDecls [])]) = [(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 $ 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  ++isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False"+isGuardFalse _ = False+++rename (UnQual (Ident ('(':xs))) | head xs `notElem` ",)" = UnQual $ Symbol $ init xs+rename x = x+++isAtom Con{} = True+isAtom Var{} = True+isAtom Lit{} = True+isAtom Paren{} = True+isAtom _ = False+++paren x = if isAtom x then x else Paren x++sl = SrcLoc "" 0 0++noSl mr = transformBi (const sl) mr+++title (x:xs) = toUpper x : xs++qname = UnQual . name+var = Var . qname+con = Con . qname+tyVar = TyVar . name+tyVarBind = UnkindedVar . name+tyCon = TyCon . qname+pVar = PVar . name+qvop = QVarOp . UnQual . Symbol++dataDeclType :: DataDecl -> Type+dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)++dataDeclFields :: DataDecl -> [String]+dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors+++-- A declaration that is either a DataDecl of GDataDecl+type DataDecl = Decl+type CtorDecl = Either QualConDecl GadtDecl+type FieldDecl = [(String, BangType)]++type FullDataDecl = (ModuleName, DataDecl)+++moduleName (Module _ name _ _ _ _ _) = name+moduleDecls (Module _ _ _ _ _ _ decls) = decls+moduleImports (Module _ _ _ _ _ imps _) = imps+modulePragmas (Module _ _ pragmas _ _ _ _) = pragmas+++showDecls x = unlines $ map prettyPrint x+++unParseOk (ParseOk x) = x+++tyApp x [] = x+tyApp x xs = TyApp (tyApp x $ init xs) (last xs)+++tyFun [x] = x+tyFun (x:xs) = TyFun x (tyFun xs)+++apps x [] = x+apps x (y:ys) = apps (App x y) ys+++bind :: String -> [Pat] -> Exp -> Decl+bind s p e = binds s [(p,e)]++binds :: String -> [([Pat], Exp)] -> Decl+binds n [([],e)] = PatBind sl (pVar n) Nothing (UnGuardedRhs e) (BDecls [])+binds n xs = FunBind [Match sl (name n) p Nothing (UnGuardedRhs e) (BDecls []) | (p,e) <- xs]+++fromBangType (BangedTy x) = x+fromBangType (UnBangedTy x) = x+fromBangType (UnpackedTy x) = x+++isDataDecl :: Decl -> Bool+isDataDecl DataDecl{} = True+isDataDecl GDataDecl{} = True+isDataDecl _ = False+++dataDeclSrcLoc :: DataDecl -> SrcLoc+dataDeclSrcLoc (DataDecl sl _ _ _ _ _ _) = sl+dataDeclSrcLoc (GDataDecl sl _ _ _ _ _ _ _) = sl++dataDeclName :: DataDecl -> String+dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name+dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name++dataDeclVars :: DataDecl -> [String]+dataDeclVars (DataDecl _ _ _ _ vars _ _) = map prettyPrint vars++dataDeclArity :: DataDecl -> Int+dataDeclArity = length . dataDeclVars++dataDeclCtors :: DataDecl -> [CtorDecl]+dataDeclCtors (DataDecl _ _ _ _ _ ctors _) = map Left ctors+++ctorDeclName :: CtorDecl -> String+ctorDeclName = prettyPrint . ctorDeclName'++ctorDeclName' :: CtorDecl -> Name+ctorDeclName' (Left (QualConDecl _ _ _ (ConDecl name _))) = name+ctorDeclName' (Left (QualConDecl _ _ _ (InfixConDecl _ name _))) = name+ctorDeclName' (Left (QualConDecl _ _ _ (RecDecl name _))) = name++ctorDeclFields :: CtorDecl -> FieldDecl+ctorDeclFields (Left (QualConDecl _ _ _ (ConDecl name fields))) = map ((,) "") fields+ctorDeclFields (Left (QualConDecl _ _ _ (InfixConDecl x1 name x2))) = map ((,) "") [x1,x2]+ctorDeclFields (Left (QualConDecl _ _ _ (RecDecl name fields))) = [(prettyPrint a, b) | (as,b) <- fields, a <- as]++ctorDeclArity :: CtorDecl -> Int+ctorDeclArity = length . ctorDeclFields

@@ -0,0 +1,208 @@+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}++module Language.Haskell.Convert(Convert, convert) where++import Language.Haskell as HS+import Language.Haskell.TH.Syntax as TH+import Control.Exception+import Data.Typeable+import System.IO.Unsafe+import Data.Maybe+++class (Typeable a, Typeable b, Show a, Show b) => Convert a b where+    conv :: a -> b+++convert :: forall a b . Convert a b => a -> b+convert a = unsafePerformIO $+        (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)+    where+        msg e = "Could not convert " ++ show (typeOf a) ++ " to " +++                show (typeOf (undefined :: b)) ++ "\n" ++ show a +++                "\n" ++ show e++++appT = foldl AppT++c mr = convert mr++instance Convert a b => Convert [a] [b] where+    conv = map c++++instance Convert TH.Dec HS.Decl where+    conv x = case x of+        DataD cxt n vs con ds -> f DataType cxt n vs con ds+        NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds+        where+            f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []++instance Convert TH.Name HS.TyVarBind where+    conv = UnkindedVar . c++instance Convert TH.Name HS.Name where+    conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2+        where x2 = show x++instance Convert TH.Name HS.QName where+    conv x = if x2 == Ident "[]" then Special ListCon else UnQual x2+        where x2 = c x++instance Convert TH.Con HS.QualConDecl where+    conv (ForallC vs cxt x) = QualConDecl sl (c vs) (c cxt) (c x)+    conv x = QualConDecl sl [] [] (c x)++instance Convert TH.Con HS.ConDecl where+    conv (NormalC n xs) = ConDecl (c n) (c xs)+    conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs]+    conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y)++instance Convert TH.StrictType HS.BangType where+    conv (IsStrict, x) = BangedTy $ c x+    conv (NotStrict, x) = UnBangedTy $ c x++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 (AppT ListT x) = TyList $ c x+    conv (TupleT _) = TyTuple Boxed []+    conv (AppT x y) = case c x of+        TyTuple b xs -> TyTuple b $ xs ++ [c y]+        x -> TyApp x $ c y++instance Convert TH.Type HS.Asst where+    conv (ConT x) = ClassA (UnQual $ c x) []+    conv (AppT x y) = case c x of+        ClassA a b -> ClassA a (b ++ [c y])++++instance Convert HS.Decl TH.Dec where+    conv (InstDecl _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds]+    conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms)+    conv (PatBind _ p _ bod ds) = ValD (c p) (c bod) (c ds)+    conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)++instance Convert HS.Asst TH.Type where+    conv (InfixA x y z) = c $ ClassA y [x,z]+    conv (ClassA x y) = appT (ConT $ c x) (c y)++instance Convert HS.Type TH.Type where+    conv (TyCon (Special ListCon)) = ListT+    conv (TyCon (Special UnitCon)) = TupleT 0+    conv (TyParen x) = c x+    conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)+    conv (TyVar x) = VarT $ c x+    conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x+    conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y)+    conv (TyList x) = AppT ListT (c x)+    conv (TyTuple _ x) = appT (TupleT (length x)) (c x)+    conv (TyApp x y) = AppT (c x) (c y)++instance Convert HS.Name TH.Name where+    conv = mkName . filter (`notElem` "()") . prettyPrint++instance Convert HS.Match TH.Clause where+    conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds)++instance Convert HS.Rhs TH.Body where+    conv (UnGuardedRhs x) = NormalB (c x)+    conv (GuardedRhss x) = GuardedB (c x)++instance Convert HS.Exp TH.Exp where+    conv (Con (Special UnitCon)) = TupE []+    conv (Var x) = VarE (c x)+    conv (Con x) = ConE (c x)+    conv (Lit x) = LitE (c x)+    conv (App x y) = AppE (c x) (c y)+    conv (Paren x) = c x+    conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z)+    conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing+    conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z)+    conv (Lambda _ x y) = LamE (c x) (c y)+    conv (Tuple x) = TupE (c x)+    conv (If x y z) = CondE (c x) (c y) (c z)+    conv (Let x y) = LetE (c x) (c y)+    conv (Case x y) = CaseE (c x) (c y)+    conv (Do x) = DoE (c x)+    conv (EnumFrom x) = ArithSeqE $ FromR (c x)+    conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y)+    conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y)+    conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)+    conv (List x) = ListE (c x)+    conv (ExpTypeSig _ x y) = SigE (c x) (c y)+    conv (RecConstr x y) = RecConE (c x) (c y)+    conv (RecUpdate x y) = RecUpdE (c x) (c y) +    -- Work around bug 3395, convert to do notation instead+    conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x]++instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where+    conv = undefined++instance Convert HS.Binds [TH.Dec] where+    conv (BDecls x) = c x++instance Convert HS.Pat TH.Pat where+    conv (PParen x) = c x+    conv (PLit x) = LitP (c x)+    conv (PTuple x) = TupP (c x)+    conv (PApp x y) = ConP (c x) (c y)+    conv (PVar x) = VarP (c x)+    conv (PInfixApp x y z) = InfixP (c x) (c y) (c z)+    conv (PIrrPat x) = TildeP (c x)+    conv (PAsPat x y) = AsP (c x) (c y)+    conv (PWildCard) = WildP+    conv (PRec x y) = RecP (c x) (c y)+    conv (PList x) = ListP (c x)+    conv (PatTypeSig _ x y) = SigP (c x) (c y)++instance Convert HS.Literal TH.Lit where+    conv (Char x) = CharL x+    conv (String x) = StringL x+    conv (Int x) = IntegerL x+    conv (Frac x) = RationalL x+    conv (PrimInt x) = IntPrimL x+    conv (PrimWord x) = WordPrimL x+    conv (PrimFloat x) = FloatPrimL x+    conv (PrimDouble x) = DoublePrimL x++instance Convert HS.QName TH.Name where+    conv (UnQual x) = c x+    conv (Qual m x) = c (Ident $ prettyPrint m ++ "." ++ prettyPrint x)++instance Convert HS.PatField TH.FieldPat where+    conv = undefined++instance Convert HS.QOp TH.Exp where+    conv (QVarOp x) = c $ Var x+    conv (QConOp x) = c $ Con x++instance Convert HS.Alt TH.Match where+    conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)++instance Convert HS.Stmt TH.Stmt where+    conv (Generator _ x y) = BindS (c x) (c y)+    conv (LetStmt x) = LetS (c x)+    conv (Qualifier x) = NoBindS (c x)++instance Convert HS.QualStmt TH.Stmt where+    conv (QualStmt x) = c x++instance Convert HS.FieldUpdate TH.FieldExp where+    conv (FieldUpdate x y) = (c x, c y)++instance Convert HS.TyVarBind TH.Name where+    conv (UnkindedVar x) = c x++instance Convert HS.GuardedAlts TH.Body where+    conv (UnGuardedAlt x) = NormalB (c x)+    conv (GuardedAlts x) = GuardedB (c x)++instance Convert HS.GuardedAlt (TH.Guard, TH.Exp) where+    conv (GuardedAlt _ x y) = (PatG (c x), c y)

@@ -5,7 +5,6 @@     module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,     module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr,     module Language.Haskell.TH.Data,   module Language.Haskell.TH.ExpandSynonym,-    module Language.Haskell.TH.SYB     ) where  import Language.Haskell.TH.Syntax@@ -14,7 +13,6 @@ import Language.Haskell.TH.FixedPpr import Language.Haskell.TH.ExpandSynonym import Language.Haskell.TH.Data-import Language.Haskell.TH.SYB  import Control.Monad 

@@ -18,8 +18,8 @@   dataName :: DataDef -> String-dataName (DataD    _ name _ _ _) = show (unqualifiedName name)-dataName (NewtypeD _ name _ _ _) = show (unqualifiedName name)+dataName (DataD    _ name _ _ _) = unqualifiedName name+dataName (NewtypeD _ name _ _ _) = unqualifiedName name  qualifiedDataName :: DataDef -> Name qualifiedDataName (DataD    _ name _ _ _) = name@@ -29,6 +29,9 @@ dataArity (DataD    _ _ xs _ _) = length xs dataArity (NewtypeD _ _ xs _ _) = length xs +dataArgs :: DataDef -> [Name]+dataArgs (DataD _cx name args cons _derv) = args+dataArgs (NewtypeD cx name args con derv) = args  dataCtors :: DataDef -> [CtorDef] dataCtors (DataD    _ _ _ xs _) = xs@@ -36,9 +39,9 @@   ctorName :: CtorDef -> String-ctorName (NormalC name _ ) = show (unqualifiedName name)-ctorName (RecC name _    ) = show (unqualifiedName name)-ctorName (InfixC _ name _) = show (unqualifiedName name)+ctorName (NormalC name _ ) = unqualifiedName name+ctorName (RecC name _    ) = unqualifiedName name+ctorName (InfixC _ name _) = unqualifiedName name ctorName (ForallC _ _ c  ) = ctorName c  qualifiedCtorName :: CtorDef -> Name@@ -67,7 +70,7 @@   ctorFields :: CtorDef -> [String]-ctorFields (RecC name varStrictType) = [show (unqualifiedName name) | (name,strict,typ) <- varStrictType]+ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType] ctorFields _ = []  @@ -79,7 +82,12 @@                     ('.':xs) -> takeWhile (== '.') xs                     xs -> reverse $ takeWhile (/= '.') xs +-- i_123432 -> i+dropNumber :: String -> String+dropNumber xs = if all isDigit a then reverse (tail b) else xs+    where (a,b) = break (== '_') $ reverse xs + normData :: DataDef -> DataDef normData = everywhere (mkT normType)     where@@ -87,8 +95,8 @@         normType (ConT x) | show x == "[]" = ListT         normType x = x -unqualifiedName :: Name -> Name-unqualifiedName = mkName . dropModule . show+unqualifiedName :: Name -> String+unqualifiedName = dropModule . show   -- convert AppT chains back to a proper list@@ -109,13 +117,3 @@                     all (== ',') (take (length sx - 2) (tail sx))     where sx = show x isTupleT _ = False------- * Depreciated, old type stuff---ex_args :: DataDef -> [Name]-ex_args (DataD _cx name args cons _derv) = args-ex_args (NewtypeD cx name args con derv) = args

@@ -76,6 +76,10 @@         hed = l1 cls (lK (dataName dat) vrs)         ctx = map (l1 cls) ctxTypes +-- | Build a type signature declaration with a string name+sigN :: String -> Type -> Dec+sigN nam ty = SigD (mkName nam) ty+ -- | Build a fundecl with a string name funN :: String -> [Clause] -> Dec funN nam claus = FunD (mkName nam) claus@@ -127,7 +131,12 @@         where bNm = nameBase (toName nm)       vr = VarT . toName       raw_lit = error "raw_lit @ Type"-      tup l = foldl AppT (TupleT (length l)) l++      -- XXX work around bug in GHC < 6.10+      -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)+      tup [t] = t+      tup ts  = foldl AppT (TupleT (length ts)) ts+       lst = error "lst @ Type"  -- | Build an application node without a given head

@@ -0,0 +1,31 @@++module Main(main) where++import Language.Haskell+import Derive.Derivation+import Derive.Generate+import Derive.Test+import Derive.Flags+++main :: IO ()+main = do+    (flags,files) <- getFlags+    if Test `elem` flags then+        test+     else if Generate `elem` flags then+        generate+     else if null files then+        putStr $ "No files specified\n" ++ flagInfo+     else+        mapM_ (mainFile flags) files+++mainFile :: [Flag] -> FilePath -> IO ()+mainFile flags file = do+    src <- readFile file+    let modu = unParseOk $ parseFileContents src -- FIXME: with this file mode+    flags <- return $ foldl addFlags flags+        [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas modu]+    let res = performDerive (moduleName modu) $ wantDerive flags (src,modu)+    writeDerive file (moduleName modu) flags res

@@ -1,43 +1,2 @@ import Distribution.Simple-import Distribution.PackageDescription-import Distribution.Simple.LocalBuildInfo--import System.Directory-import System.Cmd-import System.Exit-import Control.Monad---main = defaultMainWithHooks simpleUserHooks{runTests=test}---test :: CabalBreaksTheAPI_Grr grr => Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO grr-test args bool pd lbi = do-    putStrLn "Make sure you have installed the derive you wish to test!"-    cur <- getCurrentDirectory-    setCurrentDirectory "tests"-    -    b <- doesFileExist "Small.out.hs"-    when b $ removeFile "Small.out.hs"-    i <- system $ "derive -mSmallInstances -iSmall -iData.Generics -iData.Monoid " ++-                  "-o Small.out.hs Small.hs"--    b <- doesFileExist "Small.out.hs"-    if b then system "diff -u -b Small.expected.hs Small.out.hs" >> return ()-         else putStrLn "Error: Failed to generate the output file"-    -    -- currently we turn off warnings when compiling-    -- it would be nice if we made the generated code compile without warnings-    system "ghc --make -c -w Small.out.hs"-    setCurrentDirectory cur-    return grr---class CabalBreaksTheAPI_Grr a where-    grr :: a--instance CabalBreaksTheAPI_Grr () where-    grr = ()--instance CabalBreaksTheAPI_Grr ExitCode where-    grr = ExitSuccess+main = defaultMain

@@ -1,11 +1,11 @@-Cabal-Version:  >= 1.2-Build-Type:     Custom+Cabal-Version:  >= 1.6+Build-Type:     Default Name:           derive-Version:        0.1.4+Version:        2.0.0 build-type:     Simple-Copyright:      2006-7, Neil Mitchell+Copyright:      2006-2009, Neil Mitchell Maintainer:     ndmitchell@gmail.com-Homepage:       http://www-users.cs.york.ac.uk/~ndm/derive/+Homepage:       http://community.haskell.org/~ndm/derive/ License:        BSD3 License-File:   LICENSE Author:         Neil Mitchell & Stefan O'Rear@@ -20,37 +20,64 @@ Extra-Source-Files:     derive.htm -Flag small_base-    Description: Choose the new smaller, split-up base package.+Executable derive+    Main-Is: Main.hs +    Other-Modules:+        Derive.Derivation+        Derive.Flags+        Derive.Generate+        Derive.Test+        Derive.Utils++    Build-Depends:+        directory, process, bytestring+ Library-    Extensions: CPP-    Build-Depends: template-haskell, filepath, mtl-    if impl(ghc >= 6.10)-        build-depends: base == 4.*, syb-    if flag(small_base)-        Build-Depends: base >= 3, containers, pretty, packedstring, random, process, directory-    else-        Build-Depends: base < 3-        CPP-Options: "-DTH_SYB"+    Build-Depends:+        haskell-src-exts == 1.1.*, filepath, mtl,+        base == 4.*, syb, template-haskell, uniplate, containers,+        pretty, packedstring      Exposed-Modules:-        Data.DeriveGuess         Data.DeriveTH-        Data.DeriveTraversal+        Data.DeriveDSL         Data.Derive.All+        Data.Derive.DSL.Apply+        Data.Derive.DSL.Derive+        Data.Derive.DSL.DSL+        Data.Derive.DSL.HSE+        Data.Derive.DSL.SYB+        Data.Derive.Instance.Arities+        Data.Derive.Class.Arities+        Data.Derive.Class.Default+        Data.Derive.Internal.Derivation+        Data.Derive.Internal.Instance+        Data.Derive.Internal.Traversal+        Language.Haskell+        Language.Haskell.Convert+        Language.Haskell.TH.All+        Language.Haskell.TH.Data+        Language.Haskell.TH.ExpandSynonym+        Language.Haskell.TH.FixedPpr+        Language.Haskell.TH.Helper+        Language.Haskell.TH.Peephole+        Language.Haskell.TH.SYB+-- GENERATED START         Data.Derive.Arbitrary-        Data.Derive.Arbitrary2+        Data.Derive.ArbitraryOld+        Data.Derive.Arities         Data.Derive.Binary         Data.Derive.BinaryDefer-        Data.Derive.BinaryOld         Data.Derive.Bounded         Data.Derive.Data+        Data.Derive.Default         Data.Derive.Enum         Data.Derive.EnumCyclic         Data.Derive.Eq-        Data.Derive.From+        Data.Derive.Fold         Data.Derive.Foldable+        Data.Derive.From         Data.Derive.Functor         Data.Derive.Has         Data.Derive.Is@@ -58,7 +85,6 @@         Data.Derive.Monoid         Data.Derive.NFData         Data.Derive.Ord-        Data.Derive.PlateDirect         Data.Derive.PlateTypeable         Data.Derive.Read         Data.Derive.Ref@@ -66,17 +92,6 @@         Data.Derive.Set         Data.Derive.Show         Data.Derive.Traversable-        Data.Derive.TTypeable         Data.Derive.Typeable-        Data.Derive.Uniplate         Data.Derive.Update-        Language.Haskell.TH.All-        Language.Haskell.TH.Data-        Language.Haskell.TH.ExpandSynonym-        Language.Haskell.TH.FixedPpr-        Language.Haskell.TH.Helper-        Language.Haskell.TH.Peephole-        Language.Haskell.TH.SYB--Executable derive-    Main-Is: Derive.hs+-- GENERATED STOP

@@ -52,7 +52,7 @@ <h1>Data.Derive: A User Manual</h1>  <p style="text-align:right;margin-bottom:25px;">-    by <a href="http://www.cs.york.ac.uk/~ndm/">Neil Mitchell</a> &amp; Stefan O'Rear+    by <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a> </p>  <p>@@ -72,7 +72,7 @@ <h3>Acknowledgements</h3>  <p>-    Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber.+    Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson, Joel Raymont, Benedikt Huber, Stefan O'Rear. </p>  @@ -82,15 +82,14 @@ 	Data.Derive is available using <a href="http://darcs.net/">darcs</a>: </p> <pre>-darcs get --partial <a href="http://www.cs.york.ac.uk/fp/darcs/derive">http://www.cs.york.ac.uk/fp/darcs/derive</a>+darcs get --partial <a href="http://community.haskell.org/~ndm/darcs/derive">http://community.haskell.org/~ndm/darcs/derive</a> </pre> <p> 	Install the program using the standard sequence of Cabal magic: </p> <pre>-runhaskell Setup configure-runhaskell Setup build-runhaskell Setup install+cabal update+cabal install derive </pre>  @@ -100,102 +99,42 @@ 	Data.Derive is not limited to any prebuild set of derivations, see later for how to add your own. Out of the box, we provide instances for the following libraries. </p> -<h3>Prelude</h3>--<p>-	These are the standard classes defined in the <a href="http://haskell.org/onlinereport/derived.html">Haskell Report</a>, some of which the existing <tt>deriving</tt> works upon.-</p>-<ul>-	<li><b>Eq</b></li>-	<li><b>Ord</b></li>-	<li><b>Bounded</b></li>-	<li><b>Enum</b></li>-	<li><b>EnumCyclic</b></li>-	<li><b>Functor</b></li>-        <li><b>Read</b></li>-        <li><b>Show</b></li>-</ul>--<h3>Base</h3>--<p>-	These are instances from the base libraries, but which aren't in the Haskell 98 report.-</p>-<ul>-	<li><b>Monoid</b></li>-	<li><b>NFData</b></li>-</ul>--<h3>Query</h3>--<p>-	DrIFT defines a number of useful query functions, which are technically not instances, but can be derived in a similar manner. We support some of these as from DrIFT, some with modifications, and some which are brand new:-</p>-<ul>-    <li><b>From</b></li>-    <li><b>Has</b></li>-    <li><b>Is</b></li>-    <li><b>Set</b></li>-    <li><b>LazySet</b></li>-</ul>--<h3>Generics</h3>--<p>-	We support the two classes from the first <a href="http://www.cs.vu.nl/boilerplate/">Scrap Your Boilerplate</a> paper, and the classes from the <a href="http://www-users.cs.york.ac.uk/~ndm/play/">Play library</a>:-</p>-<ul>-	<li><b>Typeable</b></li>-	<li><b>Data</b></li>-	<li><b>Play</b></li>-</ul>--<h3>Binary</h3>--<p>-	We support the new <a href="http://www.cse.unsw.edu.au/~dons/binary.html">Binary library</a>, and the <a href="http://www-users.cs.york.ac.uk/~ndm/binarydefer/">BinaryDefer library</a>.-</p>-<ul>-	<li><b>Binary</b></li>-	<li><b>BinaryDefer</b></li>-</ul>--<h3>Testing</h3>--<p>-	We support both <a href="http://www.cs.chalmers.se/~rjmh/QuickCheck/">QuickCheck</a> and the <a href="http://www.cs.york.ac.uk/fp/darcs/smallcheck/">SmallCheck library</a>:-</p>-<ul>-	<li><b>Arbitrary</b></li>-	<li><b>Serial</b></li>-</ul>--<h3>Classhacking</h3>--<p>-	From the <a href="http://homepages.cwi.nl/~ralf/HList">HList library</a>:-</p>-<ul>-	<li><b>TTypeable</b></li>-</ul>--<h3>Missing</h3>--<p>-	These derivations are in DrIFT, but not in Derive. If you need them, let us know and we'll implement them.-</p>-<ul>-	<li><b>ATermConvertible</b> - encode terms in the ATerm format.</li>-	<li><b>BitsBinary</b> - efficient binary encoding of terms.</li>-	<li><b>FunctorM</b> - derive reasonable fmapM implementation.</li>-	<li><b>GhcBinary</b> - byte sized binary encoding of terms.</li>-	<li><b>HFoldable</b> - Strafunski hfoldr.</li>-	<li><b>Haskell2Xml</b> - encode terms as XML (HaXml&lt;=1.13).</li>-	<li><b>Observable</b> - HOOD observable.</li>-	<li><b>RMapM</b> - derive reasonable rmapM implementation.</li>-	<li><b>Term</b> - Strafunski representation via Dynamic.</li>-	<li><b>XmlContent</b> - encode terms as XML (HaXml&gt;=1.14).</li>-</ul>+<!--+-- GENERATED START+-->+<li><b><a href='http://hackage.haskell.org/packages/archive/QuickCheck/latest/doc/html/Test-QuickCheck.html#t%3AArbitrary'>Arbitrary</a></b> - from the library <a href='http://hackage.haskell.org/package/QuickCheck'>QuickCheck</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/QuickCheck/1.1.0.0/doc/html/Test-QuickCheck.html#t%3AArbitrary'>ArbitraryOld</a></b> - from the library <a href='http://hackage.haskell.org/package/QuickCheck-1.1.0.0'>QuickCheck-1.1.0.0</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Arities.html#t%3AArities'>Arities</a></b> - from the library <a href='http://hackage.haskell.org/package/derive'>derive</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/binary/latest/doc/html/Data-Binary.html#t%3ABinary'>Binary</a></b> - from the library <a href='http://hackage.haskell.org/package/binary'>binary</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/binarydefer/latest/doc/html/Data-Binary-Defer.html#t%3ABinaryDefer'>BinaryDefer</a></b> - from the library <a href='http://hackage.haskell.org/package/binarydefer'>binarydefer</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ABounded'>Bounded</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3AData'>Data</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Default.html#t%3ADefault'>Default</a></b> - from the library <a href='http://hackage.haskell.org/package/derive'>derive</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum'>Enum</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum'>EnumCyclic</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEq'>Eq</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Fold.html'>Fold</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Foldable.html#t%3AFoldable'>Foldable</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html'>From</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AFunctor'>Functor</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html'>Has</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html'>Is</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-LazySet.html'>LazySet</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid'>Monoid</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/parallel/latest/doc/html/Control-Parallel-Strategies.html#t%3ANFData'>NFData</a></b> - from the library <a href='http://hackage.haskell.org/package/parallel'>parallel</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AOrd'>Ord</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-PlateTypeable.html#t%3APlateAll'>PlateTypeable</a></b> - from the library <a href='http://hackage.haskell.org/package/uniplate'>uniplate</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ARead'>Read</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html'>Ref</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial'>Serial</a></b> - from the library <a href='http://hackage.haskell.org/package/smallcheck'>smallcheck</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Set.html'>Set</a></b></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AShow'>Show</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Traversable.html#t%3ATraversable'>Traversable</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Typeable.html#t%3ATypeable'>Typeable</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Update.html'>Update</a></b></li>+<!--+-- GENERATED STOP+-->  <h2>Using the Derive program</h2> @@ -262,9 +201,9 @@ </p>  <pre>+{-# LANGUAGE TemplateHaskell #-} import Data.DeriveTH-import Data.Derive.Eq-import Data.Derive.Binary+import Data.Binary  data Color = RGB Int Int Int            | CMYK Int Int Int Int@@ -275,7 +214,7 @@ </pre>  <p>-	Note two things.  First, we need to import the derivations.  By convention, a derivation for a class <tt>FooBar</tt> is located in module <tt>Data.Derive.FooBar</tt> (nota bene: this need not be in package "derive") and is exported with the name <tt>makeFooBar</tt>.  Secondly, we need to tell the compiler to insert the instance using the TH <em>splice</em> construct, <tt>$( ... )</tt> (the spaces are optional).  The splice causes the compiler to run the function <tt>derive</tt> (exported from <tt>Data.DeriveTH</tt>), passing arguments <tt>makeFooBar</tt> and <tt>''Color</tt>.  The second argument deserves more explanation; it is a quoted symbol, somewhat like a quoted symbol in Lisp and with deliberately similar syntax.  (Two apostrophes are used to specify that this name is to be resolved as a type constructor; just <tt>'Color</tt> would look for a <i>data</i> constructor named <tt>Color</tt>.)+	We need to tell the compiler to insert the instance using the TH <em>splice</em> construct, <tt>$( ... )</tt> (the spaces are optional).  The splice causes the compiler to run the function <tt>derive</tt> (exported from <tt>Data.DeriveTH</tt>), passing arguments <tt>makeFooBar</tt> and <tt>''Color</tt>.  The second argument deserves more explanation; it is a quoted symbol, somewhat like a quoted symbol in Lisp and with deliberately similar syntax.  (Two apostrophes are used to specify that this name is to be resolved as a type constructor; just <tt>'Color</tt> would look for a <i>data</i> constructor named <tt>Color</tt>.) </p>  <h2>Writing a New Derivation</h2>@@ -290,63 +229,8 @@ 	<li>Not record based - the derivation must not change on record fields. <tt>Show</tt> outputs the fields, so this is not allowed.</li> </ul> <p>-	If however your instance does meet these properties, you can use derivation by guess. Many instances do meet these conditions: <tt>Eq</tt>, <tt>Ord</tt>, <tt>Data</tt>, <tt>Serial</tt> etc.-</p>--<h3>Derivation by Guess</h3>--<p>-	This is a unique feature of this library. You simply give an instance, and the program guesses what your instance derivation code should look like, and returns it. You paste the code in, and you have written an instance without learning any of the types or functions required to construct the abstract syntax. For example, lets take the <tt>Data</tt> instance. I recommend reading through the source in <tt>Data.Derive.Data</tt> first, then matching it to this description.-</p>-<p>-	First copy the Data file, changing all the obvious bits (<tt>makeData</tt> etc) to whatever name you want. Next change the example to match your requirements. You basically define an instance for <tt>DataName</tt> which is defined as:-</p>-<pre>-data DataName a = CtorZero-                | CtorOne  a-                | CtorTwo  a a-                | CtorTwo' a a-</pre>-<p>-	Try and make your declaration as inductive as possible. Use <tt>x1</tt> etc for variable names within a constructor match. Place all the constructors in the correct order. If you would be unable to see an obvious pattern, then the guesser won't either. Once we have written our sample instance:-</p>-<pre>-> <b>ghci Data.Derive.Data -DGUESS</b>-   ___         ___ _-  / _ \ /\  /\/ __(_)- / /_\// /_/ / /  | |      GHC Interactive, version 6.6, for Haskell 98.-/ /_\\/ __  / /___| |      http://www.haskell.org/ghc/-\____/\/ /_/\____/|_|      Type :? for help.--Loading package base ... linking ... done.-Ok, modules loaded: Data.Derive.Data, Data.DeriveGuess, Language.Haskell.TH.All,- Language.Haskell.TH.SYB, Language.Haskell.TH.Data, Language.Haskell.TH.FixedPpr-, Language.Haskell.TH.Helper, Language.Haskell.TH.Peephole.-*Data.Derive.Data> <b>guess example</b>--makeData = Derivation data' "Data"-data' dat = [instance_context ["Data","Typeable"] "Data" dat [(FunD (mkName-    "gfoldl") ((map (\(ctorInd,ctor) -> (Clause [(VarP (mkName "k")),(VarP (-    mkName "r")),(ConP (mkName ("" ++ ctorName ctor)) ((map (\field -> (VarP (-    mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[]))] (NormalB (-    foldr1With (VarE (mkName "k")) ((map (\field -> (VarE (mkName ("x" ++ show-    field)))) (reverse [1..ctorArity ctor]))++[(AppE (VarE (mkName "r")) (ConE-    (mkName ("" ++ ctorName ctor))))]++[]))) [])) (id (zip [0..] (dataCtors dat-    ))))++[]))]]-</pre>-<p>-	And thats it. The block of code spewed out will generate <tt>Data</tt> instances, we just paste it back into the file.-</p>-<p>-	There is lots of clever stuff, induction hypotheses etc going on behind all this. If you have an instance which you think should be inferable, but isn't, then <a href="http://www-users.cs.york.ac.uk/~ndm/contact/">let me know</a>.-</p>--<h3>Derivation by Coding</h3>--<p>-	We use the Template Haskell data types extensively, for examples take a look at <tt>Binary</tt> and <tt>Functor</tt>. Its not particularly hard, but it is harder than just having them guessed.+	If however your instance does meet these properties, you can use derivation by guess. Many instances do meet these conditions, for examples see: <tt>Eq</tt>, <tt>Ord</tt>, <tt>Data</tt>, <tt>Serial</tt> etc. If however you need to code the derivation manually see examples such as <tt>Update</tt> and <tt>Functor</tt>. </p>-      </body> </html>