packages feed

derive 0.1 → 0.1.1

raw patch · 45 files changed

+1017/−506 lines, 45 filesdep +containersdep +directorydep +packedstringdep ~basesetup-changednew-uploader

Dependencies added: containers, directory, packedstring, pretty, process, random

Dependency ranges changed: base

Files

Data/Derive/All.hs view
@@ -2,27 +2,32 @@ -- Data.Derive derivations. module Data.Derive.All (module D) where -import Data.Derive.Arbitrary   as D-import Data.Derive.Binary      as D-import Data.Derive.BinaryDefer as D-import Data.Derive.Bounded     as D-import Data.Derive.Data        as D-import Data.Derive.Enum        as D-import Data.Derive.EnumCyclic  as D-import Data.Derive.Eq          as D-import Data.Derive.From        as D-import Data.Derive.Functor     as D-import Data.Derive.Has         as D-import Data.Derive.Is          as D-import Data.Derive.LazySet     as D-import Data.Derive.Monoid      as D-import Data.Derive.NFData      as D-import Data.Derive.Ord         as D-import Data.Derive.Play        as D-import Data.Derive.PlayAll     as D-import Data.Derive.Read        as D-import Data.Derive.Serial      as D-import Data.Derive.Set         as D-import Data.Derive.Show        as D-import Data.Derive.TTypeable   as D-import Data.Derive.Typeable    as D+import Data.Derive.Arbitrary        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.Enum             as D+import Data.Derive.EnumCyclic       as D+import Data.Derive.Eq               as D+import Data.Derive.Foldable         as D+import Data.Derive.From             as D+import Data.Derive.Functor          as D+import Data.Derive.Has              as D+import Data.Derive.Is               as D+import Data.Derive.LazySet          as D+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+import Data.Derive.Serial           as D+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
Data/Derive/Arbitrary.hs view
@@ -23,7 +23,6 @@  example = (,) "Arbitrary" [d| -     instance Arbitrary a => Arbitrary (DataName a) where         arbitrary = do             x <- choose (0,3)@@ -47,7 +46,7 @@ #endif  makeArbitrary :: Derivation-makeArbitrary = Derivation arbitrary' "Arbitrary"+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
Data/Derive/Arbitrary2.hs view
@@ -18,7 +18,6 @@  example = (,) "Arbitrary" [d| -     instance Arbitrary a => Arbitrary (DataName a) where         arbitrary = do             x <- choose (0,3)@@ -37,7 +36,7 @@ #endif  makeArbitrary :: Derivation-makeArbitrary = Derivation arbitrary' "Arbitrary"+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
Data/Derive/Binary.hs view
@@ -12,7 +12,7 @@ import Data.List  makeBinary :: Derivation-makeBinary = Derivation derive "Binary"+makeBinary = derivation derive "Binary"  derive dat =         simple_instance "Binary" dat [funN "put" pbody, funN "get" gbody]
Data/Derive/BinaryDefer.hs view
@@ -26,7 +26,7 @@ #endif  makeBinaryDefer :: Derivation-makeBinaryDefer = Derivation binarydefer' "BinaryDefer"+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
+ Data/Derive/BinaryOld.hs view
@@ -0,0 +1,93 @@+-- 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))])) [])])])]]
Data/Derive/Bounded.hs view
@@ -25,7 +25,7 @@ #endif  makeBounded :: Derivation-makeBounded = Derivation bounded' "Bounded"+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 (
Data/Derive/Data.hs view
@@ -30,7 +30,7 @@ #endif  makeData :: Derivation-makeData = Derivation data' "Data"+makeData = derivation data' "Data"  data' dat = [instance_context ["Data","Typeable"] "Data" dat [FunD (mkName     "gfoldl") ((map (\(ctorInd,ctor) -> (Clause [(VarP (mkName "k")),(VarP (
Data/Derive/Enum.hs view
@@ -32,7 +32,7 @@ #endif  makeEnum :: Derivation-makeEnum = Derivation enum' "Enum"+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))
Data/Derive/EnumCyclic.hs view
@@ -40,7 +40,7 @@ #endif  makeEnumCyclic :: Derivation-makeEnumCyclic = Derivation enumCyclic' "EnumCyclic"+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
Data/Derive/Eq.hs view
@@ -24,7 +24,7 @@ #endif  makeEq :: Derivation-makeEq = Derivation eq' "Eq"+makeEq = derivation eq' "Eq" eq' dat = [instance_context ["Eq"] "Eq" dat [FunD (mkName "==") ((map (\(ctorInd     ,ctor) -> (Clause [(ConP (mkName (ctorName ctor)) ((map (\field -> (VarP (     mkName ("x" ++ show field)))) (id [1..ctorArity ctor]))++[])),(ConP (mkName
+ Data/Derive/Foldable.hs view
@@ -0,0 +1,31 @@+{-+    This module is not written/maintained by the usual Data.Derive author.++    MAINTAINER: Twan van Laarhoven +    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"++    Please send all patches to this module to Neil (ndmitchell -at- gmail),+    and CC Twan.+-}++-- NOTE: Cannot be guessed as it relies on type information++module Data.Derive.Foldable(makeFoldable) where++import Language.Haskell.TH.All+import Data.DeriveTraversal+++makeFoldable :: Derivation+makeFoldable = derivation derive "Foldable"++derive dat = traversalInstance1 foldrTraversal "Foldable" dat++foldrTraversal = defaultTraversalType+        { traversalName   = "foldr"+        , traversalFunc   = \n a -> l1 "flip" (l1 n a)+        , traversalPlus   = fail "variable used in multiple positions in a data type"+        , traverseTuple   =         foldr (.:) id'+        , traverseCtor    = const $ foldr (.:) id'+        , traverseFunc    = \pat rhs -> sclause [vr "f", vr "b", pat] (AppE rhs (vr "b"))+        }
Data/Derive/From.hs view
@@ -28,7 +28,7 @@ #endif  makeFrom :: Derivation-makeFrom = Derivation from' "From"+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 (
Data/Derive/Functor.hs view
@@ -1,3 +1,13 @@+{-+    This module is not written/maintained by the usual Data.Derive author.++    MAINTAINER: Twan van Laarhoven +    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"++    Please send all patches to this module to Neil (ndmitchell -at- gmail),+    and CC Twan.+-}+ -- NOTE: Cannot be guessed as it relies on type information  -- | Derives 'Functor', as discussed on the Haskell-prime mailing list:@@ -5,65 +15,24 @@ module Data.Derive.Functor(makeFunctor) where  import Language.Haskell.TH.All-import Data.List+import Data.DeriveTraversal   makeFunctor :: Derivation-makeFunctor = Derivation derive "Functor"--derive dat- | dataArity dat == 0 = []- | otherwise          = generic_instance (classFor arg) dat [] [funN (fmapFor arg) body]-    where-        arg  = Arg False 1 -- TODO : make a parameter?-        body = map (deriveFunctorCtor dat arg) (dataCtors dat)---- | Derive Functor over a given argument number for a type---   return (derived function, required instances)-deriveFunctorCtor :: DataDef -> Arg -> CtorDef -> Clause-deriveFunctorCtor dat arg ctor = sclause lhs rhs-    where-       name = ctorName ctor-       types = ctorRTypes dat ctor-       arity = length types-       args = map return $ take arity ['a'..]-       lhs = [vr "fun", lK name (map vr args)]-       rhs = lK name $ zipWith AppE (map (deriveFunctorType arg) types) (map vr args)---- | Derive Functor over a given argument number for a type---   return (derived function, required instances)-deriveFunctorType :: Arg -> RType -> Exp-deriveFunctorType arg (RType (TypeCon "->") [a,b]) -- a -> b-  | isId af && isId bf  =  id'-  | isId af             =  InfixE Nothing   (l0 ".") (Just bf)-  | isId bf             =  InfixE (Just af) (l0 ".") Nothing-  | otherwise           =  LamE [l0 "arg"] $ l2 "." af (l2 "." (l0 "arg") bf)-    where af = deriveFunctorType arg{co=not (co arg)} a-          bf = deriveFunctorType arg                  b-deriveFunctorType arg (RType tycon args)-    = foldl (.:) (deriveFunctorCon arg tycon)-                 (zipWith fmapAp (map (Arg False) [0..])-                                 (map (deriveFunctorType arg) args))---- | Derive Functor over a given argument number for a type constructor-deriveFunctorCon :: Arg -> TypeCon -> Exp-deriveFunctorCon (Arg False i) (TypeArg j) | i == j = l0 "fun"-deriveFunctorCon (Arg True  i) (TypeArg j) | i == j = error "argument used in contravariant position"-deriveFunctorCon _             _                    = id'----- | Is a function the identity function?-isId = (== id')----- | optimized fmap application-fmapAp arg b- | isId b    = id'- | otherwise = l1 (fmapFor arg) b+makeFunctor = derivation derive "Functor" +derive dat = traversalInstance1 functorTraversal "Functor" dat --- | Derive Functor or CoFunctor over an argument-data Arg = Arg { co :: Bool, position :: Int }+functorTraversal = defaultTraversalType+        { traversalName   = "fmap"+        , traverseArrow   = functorForArrowType+        , traverseFunc    = \pat rhs -> sclause [vr "f", pat] rhs+        } -fmapFor  (Arg co i) = (if co then "co" else "") ++ "fmap"    ++ (if i > 1 then show i else "")-classFor (Arg co i) = (if co then "Co" else "") ++ "Functor" ++ (if i > 1 then show i else "")+functorForArrowType :: Exp -> Exp -> Exp+functorForArrowType a b+  | isId a && isId b  =  id'+  | isId a            =  InfixE Nothing  (l0 ".") (Just b)+  | isId b            =  InfixE (Just a) (l0 ".") Nothing+  | otherwise         =  LamE [l0 "arg"] $ a .: l0 "arg" .: b+ where isId = (id'==)
Data/Derive/Has.hs view
@@ -27,7 +27,7 @@ -}  makeHas :: Derivation-makeHas = Derivation has' "Has"+makeHas = derivation has' "Has"  has' dat = map f fields     where
Data/Derive/Is.hs view
@@ -1,3 +1,4 @@+ {-# OPTIONS_GHC -fth -cpp #-}  -- | A pseudo derivation.  For each constructor of the data type, @Is@@@ -24,7 +25,7 @@ #endif  makeIs :: Derivation-makeIs = Derivation is' "Is"+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"))) [])]
Data/Derive/LazySet.hs view
@@ -29,7 +29,7 @@ -}  makeLazySet :: Derivation-makeLazySet = Derivation lazyset' "LazySet"+makeLazySet = derivation lazyset' "LazySet"  lazyset' dat = map f fields     where
Data/Derive/Monoid.hs view
@@ -18,7 +18,7 @@ -}  makeMonoid :: Derivation-makeMonoid = Derivation monoid' "Monoid"+makeMonoid = derivation monoid' "Monoid"  monoid' dat | length (dataCtors dat) == 1          = [instance_default "Monoid" dat [funN "mempty" [empty],funN "mappend" [append]]]
Data/Derive/NFData.hs view
@@ -23,7 +23,7 @@ #endif  makeNFData :: Derivation-makeNFData = Derivation nFData' "NFData"+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]
Data/Derive/Ord.hs view
@@ -32,7 +32,7 @@ #endif  makeOrd :: Derivation-makeOrd = Derivation ord' "Ord"+makeOrd = derivation ord' "Ord" ord' dat = [instance_context ["Ord"] "Ord" dat [FunD (mkName "compare") [(Clause     [(VarP (mkName "a")),(VarP (mkName "b"))] (NormalB (applyWith (VarE (mkName     "check")) [(VarE (mkName "a")),(VarE (mkName "b"))])) [FunD (mkName "check"
+ Data/Derive/PlateDirect.hs view
@@ -0,0 +1,57 @@+-- 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"++-}
+ Data/Derive/PlateTypeable.hs view
@@ -0,0 +1,48 @@+{-# 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|++    instance (PlateAll a (DataName a), Typeable a) => Uniplate (DataName a) where+        uniplate = uniplateAll++    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++    |]++#endif+++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))))++[]))]]
− Data/Derive/Play.hs 
@@ -1,188 +0,0 @@--- NOTE: Cannot be guessed as it relies on type information---- | Derive Play, implemented for tuples and lists.-module Data.Derive.Play(makePlay) 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----makePlay :: Derivation-makePlay = Derivation play' "Play"---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 $ "Play 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----play' dat =-        [instance_default "Play" dat [funN "getChildren" gbody, funN "replaceChildren" 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
− Data/Derive/PlayAll.hs 
@@ -1,48 +0,0 @@-{-# OPTIONS_GHC -fth -cpp -fglasgow-exts -fallow-undecidable-instances #-}--module Data.Derive.PlayAll(makePlayAll) where--import Language.Haskell.TH.All---#ifdef GUESS--import Data.Generics.PlayTypeable-import Data.DeriveGuess-import Data.Typeable--example = (,) "PlayAll" [d|--    instance (PlayAll a (DataName a), Typeable a) => Play (DataName a) where-        replaceChildren = replaceChildrenAll--    instance (Typeable t, Typeable a, Play t, PlayAll a t) => PlayAll (DataName a) t where-        playAll CtorZero = play CtorZero-        playAll (CtorOne x1) = play CtorOne |+ x1-        playAll (CtorTwo x1 x2) = play CtorTwo |+ x1 |+ x2-        playAll (CtorTwo' x1 x2) = play CtorTwo' |+ x1 |+ x2--    |]--#endif---makePlayAll :: Derivation-makePlayAll = Derivation playAll' "PlayAll"-playAll' dat = [InstanceD (concat ([(map (\tdat -> (AppT (AppT (ConT (mkName-    "PlayAll")) tdat) (lK (dataName dat) (dataVars dat)))) (dataVars dat)),(map-    (\tdat -> (AppT (ConT (mkName "Typeable")) tdat)) (dataVars dat))])) (head-    [(AppT (ConT (mkName "Play")) (lK (dataName dat) (dataVars dat)))])[(ValD (-    VarP (mkName "replaceChildren")) (NormalB (VarE (mkName-    "replaceChildrenAll"))) [])],InstanceD (concat ([[(AppT (ConT (mkName-    "Typeable")) (VarT (mkName "t")))],(map (\tdat -> (AppT (ConT (mkName-    "Typeable")) tdat)) (dataVars dat)),[(AppT (ConT (mkName "Play")) (VarT (-    mkName "t")))],(map (\tdat -> (AppT (AppT (ConT (mkName "PlayAll")) tdat) (-    VarT (mkName "t")))) (dataVars dat))])) (head [(AppT (AppT (ConT (mkName-    "PlayAll")) (lK (dataName dat) (dataVars dat))) (VarT (mkName "t")))])[(-    FunD (mkName "playAll") ((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 "play")) (ConE (mkName ("" ++-    ctorName ctor))))]++[]))) [])) (id (zip [0..] (dataCtors dat))))++[]))]]
Data/Derive/Read.hs view
@@ -11,23 +11,27 @@ import Data.Char  makeRead :: Derivation-makeRead = Derivation read' "Read"+makeRead = derivation read' "Read" -read' dat = [instance_default "Read" dat [funN "readsPrec" [sclause [vr "p0", vr "r0"] body]]]+read' dat = [instance_default "Read" dat [funN "readsPrec" [sclause [vr "p0", vr "r"] body]]]     where         body = (++::) [ readit ctr | ctr <- dataCtors dat ]  readit ctr = case ctorFields ctr of [] -> norm                                     fl -> flds fl     where-        norm = l2 "readParen" (vr "p0" >: lit (10::Integer))-               (runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'))+        norm = lK "readParen"+               [vr "p0" >: lit (10::Integer),+                "r0" ->: runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'),+                l0 "r"] -        flds f = l2 "readParen" false-                 (runComp (pName . pLex "{" .-                           foldr (.) id (intersperse (pLex ",")-                                         (zipWith pField (ctv ctr 'x') f)) .-                           pLex "}") (ctp ctr 'x'))+        flds f = lK "readParen" +                 [false,+                  "r0" ->: runComp (pName . pLex "{" .+                                    foldr (.) id (intersperse (pLex ",")+                                                  (zipWith pField (ctv ctr 'x') f)) .+                                    pLex "}") (ctp ctr 'x'),+                  l0 "r"]          runComp fn ex = CompE $ fn (\k -> [ NoBindS (tup [ex, vrn 'r' k]) ]) 0
+ Data/Derive/Ref.hs view
@@ -0,0 +1,25 @@++-- | A pseudo derivation.  For each field in the data type, deriving+-- @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =+-- \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.+--+-- This is intended for use with the compositional functional references+-- described in+-- <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.+module Data.Derive.Ref(makeRef) where++import Language.Haskell.TH.All+import Data.Char+import Data.List++makeRef :: Derivation+makeRef = derivation ref' "Ref"++ref' dat = map f fields+    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")))]))]
Data/Derive/Serial.hs view
@@ -40,7 +40,7 @@ #endif  makeSerial :: Derivation-makeSerial = Derivation serial' "Serial"+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
Data/Derive/Set.hs view
@@ -23,7 +23,7 @@ -}  makeSet :: Derivation-makeSet = Derivation set' "Set"+makeSet = derivation set' "Set"  set' dat = map f fields     where
Data/Derive/Show.hs view
@@ -10,7 +10,7 @@ import Data.List  makeShow :: Derivation-makeShow = Derivation show' "Show"+makeShow = derivation show' "Show"  show' dat = [instance_default "Show" dat [funN "showsPrec" body]]     where@@ -26,9 +26,9 @@         flds f = (.::) (ssl (pname ++ " {") : fields f ++ [scl '}'])          fields [] = []-        fields fs = scl ' ' : concat (intersperse [ssl ", "] (map field (zip [0..] fs))) ++ [scl ' ']+        fields fs = scl ' ' : concat (intersperse [ssl ", "] (map field (zip (ctv ctr 'x') fs))) ++ [scl ' '] -        field (n,f) = [ ssl (f ++ " = ") , l2 "showsPrec" (lit (0::Integer)) (vrn 'x' n) ]+        field (v,f) = [ ssl (f ++ " = ") , l2 "showsPrec" (lit (0::Integer)) v ]          ssl = l1 "showString" . lit ; scl = l1 "showChar" . lit
Data/Derive/TTypeable.hs view
@@ -14,7 +14,7 @@ import Data.Bits  makeTTypeable :: Derivation-makeTTypeable = Derivation ttypeable' "TTypeable"+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] ]
+ Data/Derive/Traversable.hs view
@@ -0,0 +1,34 @@+{-+    This module is not written/maintained by the usual Data.Derive author.++    MAINTAINER: Twan van Laarhoven +    EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"++    Please send all patches to this module to Neil (ndmitchell -at- gmail),+    and CC Twan.+-}++-- NOTE: Cannot be guessed as it relies on type information++module Data.Derive.Traversable(makeTraversable) where++import Language.Haskell.TH.All+import Data.DeriveTraversal+++makeTraversable :: Derivation+makeTraversable = derivation derive "Traversable"++derive dat = traversalInstance1 traverseTraversal "Traversable" dat++traverseTraversal = defaultTraversalType+        { traversalName  = "traverse"+        , traversalId    = l0 "pure"+        , traversalPlus  = fail "variable used in multiple positions in a data type"+        , traverseTuple  = \args -> liftAN (VarE $ tupleDataName $ length args) args+        , traverseCtor   = \ctor -> liftAN (l0 ctor)+        , traverseFunc   = \pat rhs -> sclause [vr "f", pat] rhs+        }++liftAN :: Exp -> [Exp] -> Exp+liftAN base args = foldl (l2 "<*>") (l1 "pure" base) args
Data/Derive/Typeable.hs view
@@ -47,7 +47,7 @@   makeTypeable :: Derivation-makeTypeable = Derivation typeable' "Typeable"+makeTypeable = derivation typeable' "Typeable" typeable' dat = (funN nam [sclause [] (l1 "mkTyCon" $ lit $ dataName dat)])                 : map f [0..dataArity dat]     where
+ Data/Derive/Uniplate.hs view
@@ -0,0 +1,232 @@+-- 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")]+-}
Data/DeriveGuess.hs view
@@ -21,7 +21,7 @@ guess (name,x) = runQ x >>= putStr . (++) line0. widthify . (++) line1 . guessStr . unQ     where         line0 = "make" ++ name ++ " :: Derivation\n" ++-                "make" ++ name ++ " = Derivation " ++ lname ++ "' \"" ++ name ++ "\"\n"+                "make" ++ name ++ " = derivation " ++ lname ++ "' \"" ++ name ++ "\"\n"         line1 = lname ++ "' dat = "         lname = toLower (head name) : tail name @@ -50,11 +50,16 @@ -- uniquifiers and changing applications and tuplings into a standard -- form. unQ :: [Dec] -> [Dec]-unQ x = everywhere (mkT g) $ everywhere (mkT f) $ map normData x+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 match s then mkName $ dropUnder s else name+        f name = if not ("_" `isSuffixOf` s) && match s then mkName $ dropUnder s else name             where                 s = show name                 match = isPrefixOf "_" . dropWhile isDigit . reverse@@ -216,6 +221,7 @@                     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
Data/DeriveTH.hs view
@@ -22,13 +22,13 @@ -- | Derive an instance of some class. @derive@ only derives instances -- for the type of the argument. derive :: Derivation -> Name -> Q [Dec]-derive (Derivation f _) = liftM f . deriveOne+derive (Derivation f _) nm = f =<< deriveOne nm  -- | 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+    return . LitE . StringL . blankLine . show . ppr . peephole =<< f =<< deriveOne nm     where         blankLine "" = "-- Cannot derive " ++ s ++ " for " ++ show nm         blankLine xs = xs
+ Data/DeriveTraversal.hs view
@@ -0,0 +1,187 @@+{-+    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,+        traversalInstance, traversalInstance1,+        deriveTraversal+    ) where++import Language.Haskell.TH.All+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 = TraveralType
+        { traversalArg    :: Int                     -- ^ On what position are we traversing?
+        , traversalCo     :: Bool                    -- ^ covariant?
+        , traversalName   :: String                  -- ^ name of the traversal function
+        , traversalId     :: Trav                    -- ^ Identity traversal
+        , traversalDirect :: Trav                    -- ^ Traversal of 'a'
+        , traversalFunc   :: String -> 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
+++-- | Instance for a Traversable like class with just 1 method+traversalInstance1 :: TraveralType -> String -> DataDef -> [Dec]+traversalInstance1 tt nm dat = traversalInstance tt nm dat [deriveTraversal tt dat]++-- | Instance for a Traversable like class+traversalInstance :: TraveralType -> 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 :: TraveralType -> DataDef -> WithInstances Dec+deriveTraversal tt dat  =  fun+    where+        fun  = funN (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 :: TraveralType -> 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 :: TraveralType -> 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 :: TraveralType -> 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 :: TraveralType -> Int -> Trav -> Trav+traverseArg tt n e   =  traversalFunc tt (traversalNameN tt n) e++traversalNameN :: TraveralType -> Int -> String+traversalNameN tt n  =  traversalName tt ++ (if n > 1 then show n else "")+++-- | 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
Derive.hs view
@@ -1,4 +1,3 @@- module Main(main) where  import System.Console.GetOpt@@ -60,12 +59,12 @@  , Option "i"  ["import"]  (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"  , 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 split "DERIVES") "things to derive for all types"+ , 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-    split = Derive . words . map (\x -> if x == ',' then ' ' else x)+    splt = Derive . words . map (\x -> if x == ',' then ' ' else x)   getOpts :: IO ([Flag], [String])@@ -81,12 +80,12 @@         useage = usageInfo "Usage: derive [OPTION...] files..." options         exitSuccess = exitWith ExitSuccess -+main :: IO () main = do     (flags,files) <- getOpts-    files <- mapM pickFile files-    mapM_ (mainFile flags) (catMaybes files)-    when (any isNothing files) exitFailure+    fles <- mapM pickFile files+    mapM_ (mainFile flags) (catMaybes fles)+    when (any isNothing fles) exitFailure   pickFile :: FilePath -> IO (Maybe FilePath)@@ -97,7 +96,7 @@             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" ++@@ -110,31 +109,30 @@ dropAppend :: String -> (String,Bool) dropAppend xs = f 0 xs     where-        f i xs | appendMsg `isPrefixOf` xs =+        f i ys | appendMsg `isPrefixOf` ys =                 if hashString rest == chk                 then f i []-                else (xs ++ "\n\n\n\n", True)-            where (chk, rest) = span isDigit $ drop (length appendMsg) xs+                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':xs) = add '\n' (f (i+1) xs)-        f i (x:xs) = add x (f 0 xs)+        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)  -+mainFile :: [Flag] -> FilePath -> IO () mainFile flags file = do-    (fileflags,modname,datas,reqs) <- parseFile flags file-    let tmpfile = "Temp.hs"-    -        devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"+    (fileflags,pragmas,modname,datas,reqs) <- parseFile flags file+    let devs = ["'\\n': $( _derive_string_instance make" ++ cls ++ " ''" ++ ctor ++ " )"                | (ctor,cls) <- reqs] -        hscode x = "{-# OPTIONS_GHC -fth -fglasgow-exts -w #-}\n" +++    let hscode x = "{-# OPTIONS_GHC -fth -fglasgow-exts -w #-}\n" +++                   unlines pragmas ++                    "module " ++ modname ++ " where\n" ++                    "import Data.DeriveTH\n" ++-                   concat [ "import Data.Derive." ++ cls ++ "\n" | (_, cls) <- reqs ] +++                   "import Data.Derive.All\n" ++                    datas ++ "\n" ++                    "main = writeFile " ++ show x ++ " $\n" ++                    "    unlines [" ++ concat (intersperse ", " devs) ++ "]\n"@@ -142,38 +140,38 @@     -- note: Wrong on Hugs on Windows     tmpdir <- getTemporaryDirectory     b <- doesDirectoryExist tmpdir-    tmpdir <- return $ if b then tmpdir else ""-    -    (hsfile, hshndl) <- openTempFileLocal tmpdir "Temp.hs"-    (txfile, txhndl) <- openTempFileLocal tmpdir "Temp.txt"+    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-    +     system $ "ghc -e " ++ modname ++ ".main " ++ hsfile -    txhndl <- openFile txfile ReadMode-    res <- hGetContents txhndl+    txhandl <- openFile txfile ReadMode+    res <- hGetContents txhandl     length res `seq` return ()-    hClose txhndl-    +    hClose txhandl+     when (KeepTemp `notElem` flags) $ do         removeFile hsfile         removeFile txfile -    flags <- return $ fileflags ++ flags-    if Append `elem` flags then do+    flgs <- return $ fileflags ++ flags+    if Append `elem` flgs then do         src <- readFile file-        let (src2,b) = dropAppend src-        when b $ putStrLn "Warning, Checksum does not match, please edit the file manually"+        let (src2,c) = dropAppend src+        when c $ putStrLn "Warning, Checksum does not match, please edit the file manually"         writeFile file $ src2 ++ (if null res then "" else appendMsg ++ hashString res ++ "\n" ++ res)      else do-        let modline = concat $ take 1 ["module " ++ x ++ " where\n" | Module x <- flags]-            impline = unlines ["import " ++ if null i then modname else i | Import i <- flags]+        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 <- flags] of++        case [x | Output x <- flgs] of              [] -> putStr answer              (x:_) -> writeFile x answer @@ -186,16 +184,23 @@ -- 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)])+parseFile :: [Flag] -> FilePath -> IO ([Flag], [String], String, String, [(String,String)]) parseFile flags file = do         src <- liftM lines $ readFile file-        options <- if NoOpts `elem` flags then return [] else parseOptions src+        optns <- if NoOpts `elem` flags then return [] else parseOptions src+        pragmas <- return $ parsePragmas src         modname <- parseModname src-        let deriv = concat [x | Derive x <- flags ++ options]+        let deriv = concat [x | Derive x <- flags ++ optns]         (decl,req) <- return $ unzip $ concatMap (checkData deriv) $ joinLines $                                map dropComments $ filter (not . isBlank) src-        return (options, modname, unlines decl, concat req)+        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@@ -203,21 +208,21 @@                     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:xs) | "module " `isPrefixOf` x = return $ takeWhile f $ dropWhile isSpace $ drop 6 x-            where f x = not (isSpace x) && x `notElem` "("-        parseModname (x:xs) = parseModname xs+        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 ('-':'-':xs) = []++        dropComments ('-':'-':_) = []         dropComments (x:xs) = x : dropComments xs         dropComments [] = [] @@ -225,7 +230,7 @@             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,[])]@@ -241,10 +246,10 @@         parseDeriving :: String -> [String]         parseDeriving x = words $ f False x             where-                f b ('{':'-':'!':xs) = ' ' : f True  xs-                f b ('!':'-':'}':xs) = ' ' : f False xs-                f b (x:xs) = [if x == ',' then ' ' else x | b] ++ f b xs-                f b [] = []+                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
Language/Haskell/TH/All.hs view
@@ -1,9 +1,11 @@+{-# OPTIONS_GHC -w #-}  module Language.Haskell.TH.All (     module Language.Haskell.TH.All,     module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,     module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr,-    module Language.Haskell.TH.Data, module Language.Haskell.TH.SYB+    module Language.Haskell.TH.Data, +    module Language.Haskell.TH.SYB     ) where  import Language.Haskell.TH.Syntax@@ -13,11 +15,22 @@ import Language.Haskell.TH.Data import Language.Haskell.TH.SYB +import Control.Monad  + -- | The type of ways to derive classes. --   Should not really be in this module! data Derivation = Derivation {-      derivationDeriver :: DataDef -> [Dec], -- ^ The derivation function proper-      derivationName    :: String            -- ^ The name of the derivation+      derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper+      derivationName    :: String              -- ^ The name of the derivation     }+++-- create a new derivation more abstractly+derivation :: (DataDef -> [Dec]) -> String -> Derivation+derivation f = Derivation (return . f)+++derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation+derivationQ = Derivation
Language/Haskell/TH/Data.hs view
@@ -107,51 +107,6 @@  -- * Depreciated, old type stuff -data RType    = RType {typeCon :: TypeCon, typeArgs :: [RType] }-    deriving (Eq, Ord)---- | A referencing type which is not itself an application.-data TypeCon = TypeCon String -- ^ A type defined elsewhere, free in-                              -- the data declaration.-             | TypeArg  Int   -- ^ A reference to a type bound by the-                              -- type constructor; the argument to-                              -- @TypeArg@ is the index of the type-                              -- argument, counting from zero at the-                              -- left.-    deriving (Eq, Ord)---instance Show RType where-    show (RType con [])   = show con-    show (RType con args) = "(" ++ show con ++ concatMap ((" "++) . show) args ++ ")"--instance Show TypeCon where-    show (TypeCon n) = n-    show (TypeArg i) = [chr (ord 'a' + i)]-----ctorRTypes :: DataDef -> CtorDef -> [RType]-ctorRTypes dat (NormalC nm tys) = map (ex_type dat . snd) tys-ctorRTypes dat (RecC name tys)  = map (ex_type dat . (\ (x,y,z) -> z)) tys-ctorRTypes dat (InfixC t0 n t1) = map (ex_type dat . snd) [t0, t1]-ctorRTypes dat ForallC{}        = error "Existential types not yet handled"----ex_type :: DataDef -> Type -> RType-ex_type dat ForallT{}  = error "Polymorphic components not supported"-ex_type dat (VarT nm)  = case elemIndex nm (ex_args dat) of-                                Nothing -> error "impossible: tyvar not in scope"-                                Just k  -> RType (TypeArg k) []-ex_type dat (ConT nm)  = RType (TypeCon (show nm)) []-ex_type dat (TupleT k) = RType (TypeCon ("(" ++ replicate (k-1) ',' ++ ")")) []-ex_type dat (ArrowT)   = RType (TypeCon "(->)") []-ex_type dat (ListT)    = RType (TypeCon "[]") []-ex_type dat (AppT a b) = let (RType tc ar) = ex_type dat a ; arg = ex_type dat b-                         in RType tc (ar ++ [arg])-  ex_args :: DataDef -> [Name] ex_args (DataD _cx name args cons _derv) = args
Language/Haskell/TH/Helper.hs view
@@ -96,6 +96,8 @@       -- | Listing       lst :: [a] -> a instance Valcon Exp where+      lK "[]" [] = ConE (mkName "[]")+      lK "[]" xs = lst xs       lK nm@(x:_) args | isUpper x || x == ':' = foldl AppE (ConE (mkName nm)) args       lK nm@(x:_) [a,b] | isOper x = InfixE (Just a) (VarE (mkName nm)) (Just b)          where isOper x = not (isAlpha x || x == '_')
Language/Haskell/TH/Peephole.hs view
@@ -109,6 +109,12 @@ peep (InfixE (Just (AppE ret x)) bind (Just y))     | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x +peep (InfixE (Just (AppE pure x)) ap y)+    | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y++peep (InfixE (Just x) fmap (Just (AppE pure y)))+    | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)+ peep (AppE append (ListE [x]))     | append ~= "++" = peep $ AppE (l0 ":") x @@ -118,6 +124,17 @@ peep (InfixE (Just x) cons (Just (ListE xs)))     | cons ~= ":" = peep $ ListE (x:xs) +peep (AppE (AppE (AppE comp f) g) x)+    | comp ~= "."  = peep $ AppE f (peep $ AppE g x)+peep (AppE (InfixE (Just f) comp (Just g)) x)+    | comp ~= "."  = peep $ AppE f (peep $ AppE g x)++peep (AppE (AppE (AppE flip f) x) y)+    | flip ~= "flip"  = peep $ AppE (AppE f y) x++peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)+peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)+ peep (AppE f (LamE x (ListE [y])))     | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y) @@ -134,7 +151,15 @@ peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))     | x == y = z +peep (AppE len (ListE xs))+    | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs+ peep (TupE [x]) = x++peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]++peep (AppE (CaseE e [Match p (NormalB x) []]) y)+       = CaseE e [Match p (NormalB $ peep $ AppE x y) []]  -- allow easy flip to tracing mode peep x | traceMode = trace (show x) x
Language/Haskell/TH/SYB.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-deprecations #-}+{-# OPTIONS_GHC -cpp -fno-warn-missing-methods -fno-warn-deprecations -fno-warn-unused-imports #-}  module Language.Haskell.TH.SYB where @@ -6,11 +6,10 @@ import Language.Haskell.TH.Syntax import Data.PackedString -+#ifndef NO_SYB     instance Data PackedString where gfoldl k z x = z x  - typename_Name = mkTyCon "Name" instance Typeable Name     where typeOf _ = mkTyConApp typename_Name ([])@@ -364,5 +363,4 @@           gfoldl k z (ArrowT) = z ArrowT           gfoldl k z (ListT) = z ListT           gfoldl k z (AppT x1 x2) = k (k (z AppT) x1) x2--+#endif
Setup.hs view
@@ -1,2 +1,43 @@ import Distribution.Simple-main = defaultMain+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo++import System.Directory+import System.Cmd+import System.Exit+import Control.Monad+++main = defaultMainWithHooks defaultUserHooks{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 -mSmallInstancess -iSmall -iData.Generics -iData.Monoid " +++                  "-o Small.out.hs Small.hs"++    b <- doesFileExist "Small.out.hs"+    if b then system "diff -u 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
derive.cabal view
@@ -1,58 +1,76 @@+Cabal-Version:  >= 1.2 Name:           derive-Version:        0.1+Version:        0.1.1 Copyright:      2006-7, Neil Mitchell Maintainer:     ndmitchell@gmail.com Homepage:       http://www-users.cs.york.ac.uk/~ndm/derive/-Build-Depends:  base, template-haskell, filepath, mtl License:        BSD3 License-File:   LICENSE Author:         Neil Mitchell & Stefan O'Rear Synopsis:       A program and library to derive instances for data types+Category:       Development Description:     Data.Derive is a library and a tool for deriving instances for Haskell programs.     It is designed to work with custom derivations, SYB and Template Haskell mechanisms.     The tool requires GHC, but the generated code is portable to all compilers.     We see this tool as a competitor to DrIFT.-Category:       Development-Extensions:     CPP+ Extra-Source-Files:     derive.htm-Exposed-Modules:-    Data.DeriveGuess-    Data.DeriveTH-    Data.Derive.All-    Data.Derive.Arbitrary-    Data.Derive.Arbitrary2-    Data.Derive.Binary-    Data.Derive.BinaryDefer-    Data.Derive.Bounded-    Data.Derive.Data-    Data.Derive.Enum-    Data.Derive.EnumCyclic-    Data.Derive.Eq-    Data.Derive.From-    Data.Derive.Functor-    Data.Derive.Has-    Data.Derive.Is-    Data.Derive.LazySet-    Data.Derive.Monoid-    Data.Derive.NFData-    Data.Derive.Ord-    Data.Derive.Play-    Data.Derive.PlayAll-    Data.Derive.Read-    Data.Derive.Serial-    Data.Derive.Set-    Data.Derive.Show-    Data.Derive.TTypeable-    Data.Derive.Typeable-    Language.Haskell.TH.All-    Language.Haskell.TH.Data-    Language.Haskell.TH.FixedPpr-    Language.Haskell.TH.Helper-    Language.Haskell.TH.Peephole-    Language.Haskell.TH.SYB +Flag small_base+    Description: Choose the new smaller, split-up base package. -Executable:     derive-Main-Is:        Derive.hs+Library+    Extensions: CPP+    Build-Depends: template-haskell, filepath, mtl+    if flag(small_base)+        Build-Depends: base >= 3, containers, pretty, packedstring, random, process, directory+        CPP-Options: "-DNO_SYB"+    else+        Build-Depends: base < 3++    Exposed-Modules:+        Data.DeriveGuess+        Data.DeriveTH+        Data.DeriveTraversal+        Data.Derive.All+        Data.Derive.Arbitrary+        Data.Derive.Arbitrary2+        Data.Derive.Binary+        Data.Derive.BinaryDefer+        Data.Derive.BinaryOld+        Data.Derive.Bounded+        Data.Derive.Data+        Data.Derive.Enum+        Data.Derive.EnumCyclic+        Data.Derive.Eq+        Data.Derive.From+        Data.Derive.Foldable+        Data.Derive.Functor+        Data.Derive.Has+        Data.Derive.Is+        Data.Derive.LazySet+        Data.Derive.Monoid+        Data.Derive.NFData+        Data.Derive.Ord+        Data.Derive.PlateDirect+        Data.Derive.PlateTypeable+        Data.Derive.Read+        Data.Derive.Ref+        Data.Derive.Serial+        Data.Derive.Set+        Data.Derive.Show+        Data.Derive.Traversable+        Data.Derive.TTypeable+        Data.Derive.Typeable+        Data.Derive.Uniplate+        Language.Haskell.TH.All+        Language.Haskell.TH.Data+        Language.Haskell.TH.FixedPpr+        Language.Haskell.TH.Helper+        Language.Haskell.TH.Peephole+        Language.Haskell.TH.SYB++Executable derive+    Main-Is: Derive.hs
derive.htm view
@@ -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.+    Thanks to everyone who has submitted patches and given assistance, including: Twan van Laarhoven, Spencer Janssen, Andrea Vezzosi, Samuel Bronson.     Thanks also to Joel Raymont for being the first user of Data.Derive, and generally helping us feel like we weren't wasting our time. </p> @@ -263,7 +263,7 @@ </p>  <pre>-import Data.Derive.TH+import Data.DeriveTH import Data.Derive.Eq import Data.Derive.Binary @@ -276,7 +276,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.Derive.TH</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>.)+	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>.) </p>  <h2>Writing a New Derivation</h2>