derive 2.4.2 → 2.6.5
raw patch · 122 files changed
Files
- CHANGES.txt +77/−0
- Data/Derive/All.hs +0/−44
- Data/Derive/Arbitrary.hs +0/−84
- Data/Derive/ArbitraryOld.hs +0/−73
- Data/Derive/Arities.hs +0/−44
- Data/Derive/Binary.hs +0/−134
- Data/Derive/BinaryDefer.hs +0/−63
- Data/Derive/Bounded.hs +0/−44
- Data/Derive/Class/Arities.hs +0/−5
- Data/Derive/Class/Default.hs +0/−5
- Data/Derive/DSL/Apply.hs +0/−72
- Data/Derive/DSL/DSL.hs +0/−112
- Data/Derive/DSL/Derive.hs +0/−141
- Data/Derive/DSL/HSE.hs +0/−112
- Data/Derive/DSL/SYB.hs +0/−110
- Data/Derive/Data.hs +0/−155
- Data/Derive/DataAbstract.hs +0/−62
- Data/Derive/Default.hs +0/−33
- Data/Derive/Enum.hs +0/−52
- Data/Derive/EnumCyclic.hs +0/−105
- Data/Derive/Eq.hs +0/−60
- Data/Derive/Fold.hs +0/−66
- Data/Derive/Foldable.hs +0/−55
- Data/Derive/From.hs +0/−64
- Data/Derive/Functor.hs +0/−62
- Data/Derive/Has.hs +0/−40
- Data/Derive/Instance/Arities.hs +0/−15
- Data/Derive/Internal/Derivation.hs +0/−49
- Data/Derive/Internal/Instance.hs +0/−35
- Data/Derive/Internal/Traversal.hs +0/−210
- Data/Derive/Is.hs +0/−33
- Data/Derive/JSON.hs +0/−165
- Data/Derive/LazySet.hs +0/−38
- Data/Derive/Monoid.hs +0/−69
- Data/Derive/NFData.hs +0/−35
- Data/Derive/Ord.hs +0/−93
- Data/Derive/Read.hs +0/−199
- Data/Derive/Ref.hs +0/−42
- Data/Derive/Serial.hs +0/−66
- Data/Derive/Serialize.hs +0/−134
- Data/Derive/Set.hs +0/−40
- Data/Derive/Show.hs +0/−90
- Data/Derive/Traversable.hs +0/−56
- Data/Derive/Typeable.hs +0/−96
- Data/Derive/UniplateDirect.hs +0/−215
- Data/Derive/UniplateTypeable.hs +0/−72
- Data/Derive/Update.hs +0/−47
- Data/DeriveDSL.hs +0/−21
- Data/DeriveTH.hs +0/−44
- Derive/Derivation.hs +0/−100
- Derive/Flags.hs +0/−63
- Derive/Generate.hs +0/−119
- Derive/Test.hs +0/−98
- Derive/Utils.hs +0/−86
- LICENSE +1/−1
- Language/Haskell.hs +0/−293
- Language/Haskell/Convert.hs +0/−256
- Language/Haskell/TH/All.hs +0/−35
- Language/Haskell/TH/Compat.hs +0/−37
- Language/Haskell/TH/Data.hs +0/−119
- Language/Haskell/TH/ExpandSynonym.hs +0/−47
- Language/Haskell/TH/FixedPpr.hs +0/−407
- Language/Haskell/TH/Helper.hs +0/−248
- Language/Haskell/TH/Peephole.hs +0/−202
- Main.hs +3/−52
- README.md +168/−0
- derive.cabal +41/−44
- derive.htm +0/−249
- src/Data/Derive/All.hs +35/−0
- src/Data/Derive/Arbitrary.hs +106/−0
- src/Data/Derive/ArbitraryOld.hs +89/−0
- src/Data/Derive/Arities.hs +48/−0
- src/Data/Derive/Binary.hs +181/−0
- src/Data/Derive/BinaryDefer.hs +83/−0
- src/Data/Derive/Bounded.hs +56/−0
- src/Data/Derive/Class/Arities.hs +5/−0
- src/Data/Derive/Class/Default.hs +5/−0
- src/Data/Derive/DSL/Apply.hs +76/−0
- src/Data/Derive/DSL/DSL.hs +112/−0
- src/Data/Derive/DSL/Derive.hs +157/−0
- src/Data/Derive/DSL/HSE.hs +115/−0
- src/Data/Derive/DSL/SYB.hs +114/−0
- src/Data/Derive/DataAbstract.hs +79/−0
- src/Data/Derive/Default.hs +38/−0
- src/Data/Derive/EnumCyclic.hs +152/−0
- src/Data/Derive/Fold.hs +67/−0
- src/Data/Derive/From.hs +65/−0
- src/Data/Derive/Has.hs +40/−0
- src/Data/Derive/Instance/Arities.hs +14/−0
- src/Data/Derive/Internal/Derivation.hs +46/−0
- src/Data/Derive/Internal/Instance.hs +34/−0
- src/Data/Derive/Internal/Traversal.hs +219/−0
- src/Data/Derive/Is.hs +33/−0
- src/Data/Derive/JSON.hs +178/−0
- src/Data/Derive/LazySet.hs +39/−0
- src/Data/Derive/Lens.hs +41/−0
- src/Data/Derive/Monoid.hs +93/−0
- src/Data/Derive/NFData.hs +42/−0
- src/Data/Derive/Ref.hs +42/−0
- src/Data/Derive/Serial.hs +84/−0
- src/Data/Derive/Serialize.hs +182/−0
- src/Data/Derive/Set.hs +41/−0
- src/Data/Derive/UniplateDirect.hs +233/−0
- src/Data/Derive/UniplateTypeable.hs +102/−0
- src/Data/Derive/Update.hs +47/−0
- src/Data/DeriveDSL.hs +21/−0
- src/Data/DeriveMain.hs +19/−0
- src/Data/DeriveTH.hs +44/−0
- src/Derive/Derivation.hs +103/−0
- src/Derive/Flags.hs +65/−0
- src/Derive/Generate.hs +115/−0
- src/Derive/Main.hs +67/−0
- src/Derive/Test.hs +100/−0
- src/Derive/Utils.hs +86/−0
- src/Language/Haskell.hs +315/−0
- src/Language/Haskell/Convert.hs +332/−0
- src/Language/Haskell/TH/All.hs +34/−0
- src/Language/Haskell/TH/Compat.hs +55/−0
- src/Language/Haskell/TH/Data.hs +142/−0
- src/Language/Haskell/TH/ExpandSynonym.hs +47/−0
- src/Language/Haskell/TH/Helper.hs +248/−0
- src/Language/Haskell/TH/Peephole.hs +216/−0
+ CHANGES.txt view
@@ -0,0 +1,77 @@+2.6.4+ Rewrite for haskell-src-exts == 1.20.*+ #27, disable a few more extensions by default (sync with the HLint list)+2.6.3+ #24, support GHC 8.2+2.6.2+ #19, more upgrade bug fixes+2.6.1+ #19, allow haskell-src-exts-1.19+2.6+ Remove lots of derivations that didn't seem useful (Eq, Show etc)+ Change to use annotated Haskell syntax trees+ Require haskell-src-exts-1.18+2.5.26+ #17, fix incomplete pattern matches for certain types of data+2.5.25+ #14, further GHC 8.0.1 updates+2.5.24+ #14, update to GHC 8.0.1+ #15, move all the source files under src to speed up building+ Delete the FixedPpr module, was unused+2.5.23+ Require haskell-src-exts-1.17+2.5.22+ #7, #8 convert more types from TemplateHaskell+2.5.21+ Fix the homepage link+2.5.20+ #5, fix regression with higher-kinded constructors becoming context+2.5.19+ Support GHC 7.10+2.5.18+ #4, fix the read instance for nullary constructors+2.5.17+ Upgrade to haskell-src-exts-1.16+ Remove GHC 7.2 support+2.5.16+ Allow transformers-0.4 and above+2.5.15+ Allow haskell-src-exts-1.15.*+2.5.14+ #3, support GHC 7.9+2.5.13+ #622, turn on more Haskell extensions+2.5.12+ Upgrade to haskell-src-exts-1.14.*+2.5.11+ Support GHC 7.6+2.5.10+ Add derivation for Lens+ Modify the Typeable derivation to use mkTyCon3+2.5.9+ Support the Template Haskell Unpacked constructor+2.5.8+ Allow haskell-src-exts-1.13.*+2.5.7+ Allow haskell-src-exts-1.12.*+2.5.6+ Update the copyright year+ Allow transformers-0.3.*+2.5.5+ #513, allow derive to be run as a preprocessor+ Improve the documentation for UniplateDirect+2.5.4+ #394, allow tuple names in more places+ Fix error when deriving Binary on "data A = B"+2.5.3+ GHC 7.2 compatibility+2.5.2+ Relax the dependency on haskell-src-exts to < 1.12+2.5.1+ Improve documentation for deriveMain+2.5+ #257, add Data.DeriveMain.deriveMain, to allow user derivations+2.4.2+ Relax the dependency on haskell-src-exts to < 1.11+ Start of changelog
− Data/Derive/All.hs
@@ -1,44 +0,0 @@--- | This module provides convenience re-exports of all the standard--- Data.Derive derivations.-module Data.Derive.All (Derivation, derivations, module D) where--import Data.Derive.Internal.Derivation---- GENERATED START-import Data.Derive.Arbitrary as D-import Data.Derive.ArbitraryOld as D-import Data.Derive.Arities as D-import Data.Derive.Binary as D-import Data.Derive.BinaryDefer as D-import Data.Derive.Bounded as D-import Data.Derive.Data as D-import Data.Derive.DataAbstract as D-import Data.Derive.Default as D-import Data.Derive.Enum as D-import Data.Derive.EnumCyclic as D-import Data.Derive.Eq as D-import Data.Derive.Fold as D-import Data.Derive.Foldable as D-import Data.Derive.From as D-import Data.Derive.Functor as D-import Data.Derive.Has as D-import Data.Derive.Is as D-import Data.Derive.JSON as D-import Data.Derive.LazySet as D-import Data.Derive.Monoid as D-import Data.Derive.NFData as D-import Data.Derive.Ord as D-import Data.Derive.Read as D-import Data.Derive.Ref as D-import Data.Derive.Serial as D-import Data.Derive.Serialize as D-import Data.Derive.Set as D-import Data.Derive.Show as D-import Data.Derive.Traversable as D-import Data.Derive.Typeable as D-import Data.Derive.UniplateDirect as D-import Data.Derive.UniplateTypeable as D-import Data.Derive.Update as D-derivations :: [Derivation]-derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeJSON,makeLazySet,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSerialize,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate]--- GENERATED STOP
− Data/Derive/Arbitrary.hs
@@ -1,84 +0,0 @@-module Data.Derive.Arbitrary(makeArbitrary) where-{--import "QuickCheck" Test.QuickCheck--example :: Custom--instance Arbitrary (Sample a) where- arbitrary = do- x <- choose (0::Int,length [First{},Second{},Third{}] - 1)- case x of- 0 -> do return (First)- 1 -> do x1 <- arbitrary- x2 <- arbitrary- return (Second x1 x2)- 2 -> do x1 <- arbitrary- return (Third x1)- _ -> error "FATAL ERROR: Arbitrary instance, logic bug"--test :: State-instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where- arbitrary = do x1 <- arbitrary- return (StateT x1)--}--import Data.Derive.DSL.HSE-import Data.List-import Data.Generics.Uniplate.DataOnly---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeArbitrary :: Derivation-makeArbitrary = derivationCustomDSL "Arbitrary" custom $- List [Instance [] "Arbitrary" (List [App "InsDecl" (List [App- "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "arbitrary"])]),App "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"])])- ]),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 "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 []])])),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 [String- "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "BDecls"- (List [List []])])]])])])]])]),App "BDecls" (List [List []])])])])- ]--- GENERATED STOP--custom = customContext context---- Fix the context--- C a b => Arbitrary a, Arbitrary b--- a -> b => CoArbitrary a, Arbitrary b-context :: FullDataDecl -> Context -> Context-context (_,d) _ = nub $ concatMap (f True . 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)-
− Data/Derive/ArbitraryOld.hs
@@ -1,73 +0,0 @@-module Data.Derive.ArbitraryOld where-{--import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)--example :: Sample--instance Arbitrary a => Arbitrary (Sample a) where- arbitrary = do- x <- choose (0,length [First{},Second{},Third{}]-1)- case x of- 0 -> do return (First)- 1 -> do x1 <- arbitrary- x2 <- arbitrary- return (Second x1 x2)- 2 -> do x1 <- arbitrary- return (Third x1)-- coarbitrary (First) = variant 0- coarbitrary (Second x1 x2) = variant 1 . coarbitrary x1 . coarbitrary x2- coarbitrary (Third x1) = variant 2 . coarbitrary x1---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeArbitraryOld :: Derivation-makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld--dslArbitraryOld =- List [Instance ["Arbitrary"] "Arbitrary" (List [App "InsDecl" (- List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [- String "arbitrary"])]),App "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
− Data/Derive/Arities.hs
@@ -1,44 +0,0 @@-module Data.Derive.Arities where-{--import "derive" Data.Derive.Class.Arities--example :: Sample--instance Arities (Sample a) where- arities _ = [const 0 First{}, const 2 Second{}, const 1 Third{}]--test :: []--instance Arities [a] where- arities _ = [0,2]--test :: Bool--instance Arities Bool where- arities _ = [0,0]--test :: Either--instance Arities (Either a b) where- arities _ = [1,1]--}---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeArities :: Derivation-makeArities = derivationDSL "Arities" dslArities--dslArities =- List [Instance [] "Arities" (List [App "InsDecl" (List [App- "FunBind" (List [List [App "Match" (List [App "Ident" (List [- String "arities"]),List [App "PWildCard" (List [])],App "Nothing"- (List []),App "UnGuardedRhs" (List [App "List" (List [MapCtor (- Application (List [App "Var" (List [App "UnQual" (List [App- "Ident" (List [String "const"])])]),App "Lit" (List [App "Int" (- List [CtorArity])]),App "RecConstr" (List [App "UnQual" (List [App- "Ident" (List [CtorName])]),List []])]))])]),App "BDecls" (List [- List []])])]])])])]--- GENERATED STOP
− Data/Derive/Binary.hs
@@ -1,134 +0,0 @@-module Data.Derive.Binary where-{--import "binary" Data.Binary--example :: Sample--instance Binary alpha => Binary (Sample alpha) where- put x = case x of- First -> do putTag 0- Second x1 x2 -> do putTag 1 ; put x1 ; put x2- Third x1 -> do putTag 2 ; put x1- where- useTag = length [First{}, Second{}, Third{}] > 1- putTag x = when useTag (putWord8 x)-- get = do- i <- getTag- case i of- 0 -> do return (First)- 1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)- 2 -> do x1 <- get ; return (Third x1)- _ -> error "Corrupted binary data for Sample"- where- useTag = length [First{}, Second{}, Third{}] > 1- getTag = if useTag then getWord8 else return 0---test :: List--instance Binary a => Binary (List a) where- put x = case x of- Nil -> putWord8 0- Cons x1 x2 -> do putWord8 1; put x1; put x2-- get = do- i <- getWord8- case i of- 0 -> return Nil- 1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)- _ -> error "Corrupted binary data for List"--test :: Assoced--instance Binary typ => Binary (Assoced typ) where- put (Assoced x1 x2) = do put x1; put x2- get = do x1 <- get; x2 <- get; return (Assoced x1 x2)----}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeBinary :: Derivation-makeBinary = derivationDSL "Binary" dslBinary--dslBinary =- List [Instance ["Binary"] "Binary" (List [App "InsDecl" (List [App- "FunBind" (List [List [App "Match" (List [App "Ident" (List [- String "put"]),List [App "PVar" (List [App "Ident" (List [String- "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App- "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident" (- List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List- [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App- "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt- FieldIndex])])]))]),App "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
− Data/Derive/BinaryDefer.hs
@@ -1,63 +0,0 @@-module Data.Derive.BinaryDefer where-{--import "binarydefer" Data.Binary.Defer--example :: Sample--instance BinaryDefer a => BinaryDefer (Sample a) where- bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) <<! o else unit First- ,\ ~(o@(Second x1 x2)) -> if null [const () x1, const () x2] then unit (Second x1 x2) <<! o else unit Second << x1 << x2- ,\ ~(o@(Third x1)) -> if null [const () x1] then unit (Third x1) <<! o else unit Third << x1- ]--test :: FailList--instance (BinaryDefer e, BinaryDefer a) => BinaryDefer (FailList e a) where- bothDefer = defer [\ ~(o@Zoro) -> unit Zoro <<! o- ,\ ~(Fail x1) -> unit Fail << x1- ,\ ~(Const x1 x2) -> unit Const << x1 << x2- ]---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeBinaryDefer :: Derivation-makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer--dslBinaryDefer =- List [Instance ["BinaryDefer"] "BinaryDefer" (List [App "InsDecl"- (List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [- String "bothDefer"])]),App "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- "PAsPat" (List [App "Ident" (List [String "o"]),App "PParen" (List- [App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName- ])]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [- String "x",ShowInt FieldIndex])])]))])])])])])],App "If" (List [- App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"- (List [String "null"])])]),App "List" (List [MapField (Application- (List [App "Var" (List [App "UnQual" (List [App "Ident" (List [- String "const"])])]),App "Con" (List [App "Special" (List [App- "UnitCon" (List [])])]),App "Var" (List [App "UnQual" (List [App- "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])])])- ]))])]),App "InfixApp" (List [App "App" (List [App "Var" (List [- App "UnQual" (List [App "Ident" (List [String "unit"])])]),App- "Paren" (List [Application (Concat (List [List [App "Con" (List [- App "UnQual" (List [App "Ident" (List [CtorName])])])],MapField (- App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (- List [String "x",ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (- List [App "UnQual" (List [App "Symbol" (List [String "<<!"])])]),- App "Var" (List [App "UnQual" (List [App "Ident" (List [String "o"- ])])])]),Fold (App "InfixApp" (List [Tail,App "QVarOp" (List [App- "UnQual" (List [App "Symbol" (List [String "<<"])])]),Head])) (- Concat (List [Reverse (MapField (App "Var" (List [App "UnQual" (- List [App "Ident" (List [Concat (List [String "x",ShowInt- FieldIndex])])])]))),List [App "App" (List [App "Var" (List [App- "UnQual" (List [App "Ident" (List [String "unit"])])]),App "Con" (- List [App "UnQual" (List [App "Ident" (List [CtorName])])])])]]))]- )]))])])]),App "BDecls" (List [List []])])])])]--- GENERATED STOP
− Data/Derive/Bounded.hs
@@ -1,44 +0,0 @@-module Data.Derive.Bounded where-{--import Prelude--example :: Sample--instance Bounded a => Bounded (Sample a) where- minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]- maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First]---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeBounded :: Derivation-makeBounded = derivationDSL "Bounded" dslBounded--dslBounded =- List [Instance ["Bounded"] "Bounded" (List [App "InsDecl" (List [- App "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "minBound"])]),App "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
− Data/Derive/Class/Arities.hs
@@ -1,5 +0,0 @@- -module Data.Derive.Class.Arities where - -class Arities a where - arities :: a -> [Int]
− Data/Derive/Class/Default.hs
@@ -1,5 +0,0 @@- -module Data.Derive.Class.Default where - -class Default a where - def :: a
− Data/Derive/DSL/Apply.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}--module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where--import Data.Derive.DSL.HSE-import Data.Derive.DSL.DSL-import Data.List-import Data.Generics.Uniplate.DataOnly---apply :: DSL -> Input -> Out-apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}---env = Env- (error "Env.envInput: uninitialised")- (error "Env.envCtor: uninitialised")- (error "Env.envField: uninitialised")- (error "Env.envFold: uninitialised")---data Env = Env {envInput :: Input- ,envCtor :: Ctor- ,envField :: Integer- ,envFold :: (Output,Output) }--applyEnv :: DSL -> Env -> Output-applyEnv dsl env@(Env input ctor field fold) = f dsl- where- f (Instance ctx hd body) =- OApp "InstDecl"- [out- [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
− Data/Derive/DSL/DSL.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Data.Derive.DSL.DSL where--import Data.Derive.DSL.HSE-import Data.List-import Data.Data-import Data.Generics.Uniplate.DataOnly--data DSL = App String DSL{-List-}- | Concat DSL- | Reverse DSL- | String String- | ShowInt DSL- | Int Integer- | List [DSL]- - | MapField DSL- | MapCtor DSL- | DataName- | CtorName- | CtorIndex- | CtorArity- | FieldIndex- - | Fold DSL DSL- | Head- | Tail- - | Instance [String] String DSL{-[InstDecl]-}- | Application DSL{-List-}- deriving (Data,Typeable,Show)--box x = List [x]-nil = List []-append x y = Concat $ List [x,y]---fromOut :: Output -> DSL-fromOut (OApp x y) = App x (List $ map fromOut y)-fromOut (OList x) = List (map fromOut x)-fromOut (OString x) = String x-fromOut x = error $ show ("fromOut",x)---{--_1 s x1 = App s $ List [x1]-_2 s x1 x2 = App s $ List [x1,x2]-_3 s x1 x2 x3 = App s $ List [x1,x2,x3]-_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]--o x = fromOut $ out x--dslEq :: DSL-dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull- where- match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])- vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))- bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]- pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")- var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)-- dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]--}---simplifyDSL :: DSL -> DSL-simplifyDSL = transform f- where- f (Concat (List xs)) = case g xs of- [x] -> x- [] -> List []- xs -> Concat $ List xs- f x = x-- g (List x:List y:zs) = g $ List (x++y):zs- g (List []:xs) = g xs- g (String "":xs) = g xs- g (x:xs) = x : g xs- g [] = []---prettyTex :: DSL -> String-prettyTex = f id . transform g- where- bracket x = "(" ++ x ++ ")"- - f b (App x (List [])) = x- f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs- f b (App x y) = b $ x ++ " " ++ f bracket y- f b (Concat x) = b $ "concat " ++ f bracket x- f b (Reverse x) = b $ "reverse " ++ f bracket x- f b (String x) = show x- f b (ShowInt x) = b $ "showInt " ++ f bracket x- f b (Int x) = show x- f b (List []) = "nil"- f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"- f b (MapField x) = b $ "mapField " ++ f bracket x- f b (MapCtor x) = b $ "mapCtor " ++ f bracket x- f b DataName = "dataName"- f b CtorName = "ctorName"- f b CtorIndex = "ctorIndex"- f b CtorArity = "ctorArity"- f b FieldIndex = "fieldIndex"- f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y- f b Head = "head"- f b Tail = "tail"- f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z- f b (Application x) = b $ "application " ++ f bracket x-- g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y- g x = x
− Data/Derive/DSL/Derive.hs
@@ -1,141 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module Data.Derive.DSL.Derive(derive) where--import Data.Derive.DSL.HSE-import Data.Derive.DSL.DSL-import Data.Derive.DSL.Apply-import Data.List-import Data.Char-import Data.Maybe---data Guess = Guess DSL- | GuessFld Int DSL- | GuessCtr Int Bool DSL -- 0 based index, does it mention CtorName- deriving Show---ctrNames = map ctorName $ dataCtors sample---derive :: Out -> [DSL]-derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]---guess :: Output -> [Guess]--guess (OApp "InstDecl" [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
− Data/Derive/DSL/HSE.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Data.Derive.DSL.HSE(module Data.Derive.DSL.HSE, module Language.Haskell) where--import Language.Haskell hiding (List, App, String, Int)-import Data.Data-import Data.Generics.Uniplate.DataOnly-import Data.Maybe-import Data.List-import Data.Function-import Control.Monad.Trans.State--------------------------------------------------------------------------- EXAMPLES--{---- data List a = Nil | Cons a (List a)-list :: Input-list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]--}----- data Sample a = First | Second a a | Third a-sample :: Input-sample = DataDecl sl DataType [] (name "Sample") [tyVarBind "a"] ctrs []- where- ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]- ctr s i = QualConDecl sl [] [] $ ConDecl (name s) $ replicate i $ 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- - 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
− Data/Derive/DSL/SYB.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE RelaxedPolyRec, RankNTypes, ScopedTypeVariables #-}-{- OPTIONS_GHC -fglasgow-exts -}--module Data.Derive.DSL.SYB(dslSYB) where--import Data.Derive.DSL.HSE-import qualified Language.Haskell.Exts as H-import Data.Derive.DSL.DSL-import Control.Monad.Trans.State-import Control.Monad-import Data.Generics-import Data.Maybe---dslSYB :: DSL -> Maybe Out-dslSYB = syb---syb :: Data a => DSL -> Maybe a-syb = dsimple & dlistAny & dapp -- & derr--lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)-lift f = maybe Nothing id . cast . f--(&) a b x = a x `mplus` b x---dlistAny :: forall a . Data a => DSL -> Maybe a-dlistAny x | isNothing con = Nothing- | otherwise = res - where- con = readConstr dat "(:)"- val = fromConstr (fromJust con) :: a- - dat = dataTypeOf (undefined :: a)- - res = gmapQi 0 f val-- f :: Data d => d -> Maybe a- f y = fromJust $ cast $ dlist x `asTypeOf` Just [y]---dlist :: Data a => DSL -> Maybe [a]-dlist x = do- List xs <- return x- mapM syb xs---dapp :: forall a . Data a => DSL -> Maybe a-dapp x = do- App name (List args) <- return x- let dat = dataTypeOf (undefined :: a)- (res,s) = runState (fromConstrM f $ readCon dat name) (True,args)- if fst s then Just res else Nothing- where- f :: forall b . Data b => State (Bool,[DSL]) b- f = if typeOf (undefined :: b) == typeOf sl then return $ coerce sl- else do- (b,x:xs) <- get- case syb x of- Nothing -> do put (False,xs) ; return undefined- Just y -> do put (b,xs) ; return y---dsimple :: Data a => DSL -> Maybe a-dsimple = lift dinstance & lift dstring & lift dapplication & lift dmapctor & lift dsingle---dinstance :: DSL -> Maybe Decl-dinstance x = do- Instance _ name bod <- return x- bod <- syb bod- return $ InstDecl sl- [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
− Data/Derive/Data.hs
@@ -1,155 +0,0 @@-module Data.Derive.Data(makeData) where-{--import Data.Data--example :: Custom--instance (Data a, Typeable a) => Data (Sample a) where- gfoldl k r (First) = r First- gfoldl k r (Second x1 x2) = r Second `k` x1 `k` x2- gfoldl k r (Third x1) = r Third `k` x1-- gunfold k z c = case constrIndex c - 1 of- 0 -> z First- 1 -> const k 1 $ const k 2 $ z Second- 2 -> const k 1 $ z Third- i -> error $ ("Data.gunfold for Sample" ++ ", unknown index: ") ++ show i-- toConstr x@First{} = indexConstr (dataTypeOf x) (0+1)- toConstr x@Second{} = indexConstr (dataTypeOf x) (1+1)- toConstr x@Third{} = indexConstr (dataTypeOf x) (2+1)-- dataTypeOf _ = ty- where ty = mkDataType $(dataName)- [mkConstr ty "First" $(ctorFields 0) $(ctorFixity 0)- ,mkConstr ty "Second" $(ctorFields 1) $(ctorFixity 1)- ,mkConstr ty "Third" $(ctorFields 2) $(ctorFixity 2)]--test :: Computer--instance Data Computer where- gfoldl k r (Laptop x1 x2) = r Laptop `k` x1 `k` x2- gfoldl k r (Desktop x1) = r Desktop `k` x1- gunfold k z c = case constrIndex c - 1 of- 0 -> k $ k $ z Laptop- 1 -> k $ z Desktop- i -> error $ "Data.gunfold for Computer, unknown index: " ++ show i- toConstr x@Laptop{} = indexConstr (dataTypeOf x) 1- toConstr x@Desktop{} = indexConstr (dataTypeOf x) 2- dataTypeOf _ = ty- where ty = mkDataType "Example.Computer"- [mkConstr ty "Laptop" ["weight", "speed"] Prefix- ,mkConstr ty "Desktop" ["speed"] Prefix]---}--import Data.Derive.DSL.HSE-import qualified Language.Haskell as H---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeData :: Derivation-makeData = derivationCustomDSL "Data" custom $- List [Instance ["Data","Typeable"] "Data" (List [App "InsDecl" (- List [App "FunBind" (List [MapCtor (App "Match" (List [App "Ident"- (List [String "gfoldl"]),List [App "PVar" (List [App "Ident" (List- [String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])]- ),App "PParen" (List [App "PApp" (List [App "UnQual" (List [App- "Ident" (List [CtorName])]),MapField (App "PVar" (List [App- "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]- )])],App "Nothing" (List []),App "UnGuardedRhs" (List [Fold (App- "InfixApp" (List [Tail,App "QVarOp" (List [App "UnQual" (List [App- "Ident" (List [String "k"])])]),Head])) (Concat (List [Reverse (- MapField (App "Var" (List [App "UnQual" (List [App "Ident" (List [- Concat (List [String "x",ShowInt FieldIndex])])])]))),List [App- "App" (List [App "Var" (List [App "UnQual" (List [App "Ident" (- List [String "r"])])]),App "Con" (List [App "UnQual" (List [App- "Ident" (List [CtorName])])])])]]))]),App "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])])]),Concat (List [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 []])])),List [App "Alt" (List [App "PVar" (List [App "Ident"- (List [String "i"])]),App "UnGuardedAlt" (List [App "InfixApp" (- List [App "Var" (List [App "UnQual" (List [App "Ident" (List [- String "error"])])]),App "QVarOp" (List [App "UnQual" (List [App- "Symbol" (List [String "$"])])]),App "InfixApp" (List [App "Paren"- (List [App "InfixApp" (List [App "Lit" (List [App "String" (List [- Concat (List [String "Data.gunfold for ",DataName])])]),App- "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String- "++"])])]),App "Lit" (List [App "String" (List [String- ", unknown index: "])])])]),App "QVarOp" (List [App "UnQual" (List- [App "Symbol" (List [String "++"])])]),App "App" (List [App "Var"- (List [App "UnQual" (List [App "Ident" (List [String "show"])])]),- App "Var" (List [App "UnQual" (List [App "Ident" (List [String "i"- ])])])])])])]),App "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---custom d = customContext context d . customSplice splice d--splice :: FullDataDecl -> Exp -> Exp-splice d x | x ~= "dataName" = H.Lit $ H.String $ prettyPrint (fst d) ++ "." ++ dataDeclName (snd d)-splice d (H.App x (H.Lit (H.Int y)))- | x ~= "ctorFields" = H.List $ [H.Lit $ H.String a | (a,_) <- ctorDeclFields ctor, a /= ""]- | x ~= "ctorFixity" = Con (UnQual (Ident "Prefix"))- where ctor = dataDeclCtors (snd d) !! fromInteger y--context :: FullDataDecl -> Context -> Context-context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
− Data/Derive/DataAbstract.hs
@@ -1,62 +0,0 @@-{-|- For deriving Data on abstract data types.--}-module Data.Derive.DataAbstract(makeDataAbstract) where-{--import Data.Data(Data(..))--example :: Custom--instance Typeable a => Data (Sample a) where- gfoldl k r x = r x- gunfold = error "Data.gunfold not implemented on abstract data type: Sample"- toConstr = error "Data.gunfold not implemented on abstract data type: Sample"- dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"---}--import Data.Derive.DSL.HSE---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeDataAbstract :: Derivation-makeDataAbstract = derivationCustomDSL "DataAbstract" custom $- List [Instance ["Typeable"] "Data" (List [App "InsDecl" (List [App- "FunBind" (List [List [App "Match" (List [App "Ident" (List [- String "gfoldl"]),List [App "PVar" (List [App "Ident" (List [- String "k"])]),App "PVar" (List [App "Ident" (List [String "r"])])- ,App "PVar" (List [App "Ident" (List [String "x"])])],App- "Nothing" (List []),App "UnGuardedRhs" (List [App "App" (List [App- "Var" (List [App "UnQual" (List [App "Ident" (List [String "r"])])- ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String- "x"])])])])]),App "BDecls" (List [List []])])]])]),App "InsDecl" (- List [App "PatBind" (List [App "PVar" (List [App "Ident" (List [- String "gunfold"])]),App "Nothing" (List []),App "UnGuardedRhs" (- List [App "App" (List [App "Var" (List [App "UnQual" (List [App- "Ident" (List [String "error"])])]),App "Lit" (List [App "String"- (List [Concat (List [String- "Data.gunfold not implemented on abstract data type: ",DataName])]- )])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List [App- "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "toConstr"])]),App "Nothing" (List []),App "UnGuardedRhs" (List [- App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"- (List [String "error"])])]),App "Lit" (List [App "String" (List [- Concat (List [String- "Data.gunfold not implemented on abstract data type: ",DataName])]- )])])]),App "BDecls" (List [List []])])]),App "InsDecl" (List [App- "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "dataTypeOf"])]),App "Nothing" (List []),App "UnGuardedRhs" (List- [App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"- (List [String "error"])])]),App "Lit" (List [App "String" (List [- Concat (List [String- "Data.gunfold not implemented on abstract data type: ",DataName])]- )])])]),App "BDecls" (List [List []])])])])]--- GENERATED STOP--custom = customContext context--context :: FullDataDecl -> Context -> Context-context d _ = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
− Data/Derive/Default.hs
@@ -1,33 +0,0 @@-module Data.Derive.Default where-{--import "derive" Data.Derive.Class.Default--example :: Sample--instance Default a => Default (Sample a) where- def = head [First, Second (const def 1) (const def 2), Third (const def 1)]---}---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeDefault :: Derivation-makeDefault = derivationDSL "Default" dslDefault--dslDefault =- List [Instance ["Default"] "Default" (List [App "InsDecl" (List [- App "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "def"])]),App "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
− Data/Derive/Enum.hs
@@ -1,52 +0,0 @@-module Data.Derive.Enum where-{--import Prelude--example :: Sample--instance Enum (Sample a) where- toEnum 0 = First{}- toEnum 1 = Second{}- toEnum 2 = Third{}- toEnum n = error $ "toEnum " ++ show n ++ ", not defined for " ++ "Sample"-- fromEnum (First{}) = 0- fromEnum (Second{}) = 1- fromEnum (Third{}) = 2---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeEnum :: Derivation-makeEnum = derivationDSL "Enum" dslEnum--dslEnum =- List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind"- (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List- [String "toEnum"]),List [App "PLit" (List [App "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
− Data/Derive/EnumCyclic.hs
@@ -1,105 +0,0 @@-module Data.Derive.EnumCyclic where-{--import Prelude(Enum)--example :: Sample--instance Enum (Sample a) where- toEnum 0 = First{}- toEnum 1 = Second{}- toEnum 2 = Third{}- toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample"-- fromEnum (First{}) = 0- fromEnum (Second{}) = 1- fromEnum (Third{}) = 2--- succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)- where b = fromEnum a-- pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)- where b = fromEnum a---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeEnumCyclic :: Derivation-makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic--dslEnumCyclic =- List [Instance [] "Enum" (List [App "InsDecl" (List [App "FunBind"- (List [Concat (List [MapCtor (App "Match" (List [App "Ident" (List- [String "toEnum"]),List [App "PLit" (List [App "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])])]),App "App" (List [App "Var" (- List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])])- ,App "Paren" (List [App "App" (List [App "Var" (List [App "UnQual"- (List [App "Ident" (List [String "length"])])]),App "List" (List [- MapCtor (App "RecConstr" (List [App "UnQual" (List [App "Ident" (- List [CtorName])]),List []]))])])])]),App "App" (List [App "Var" (- List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])])- ,App "Paren" (List [App "InfixApp" (List [App "Var" (List [App- "UnQual" (List [App "Ident" (List [String "b"])])]),App "QVarOp" (- List [App "UnQual" (List [App "Symbol" (List [String "-"])])]),App- "Lit" (List [App "Int" (List [Int 1])])])])])])]),App "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
− Data/Derive/Eq.hs
@@ -1,60 +0,0 @@-module Data.Derive.Eq where-{--import Prelude--example :: Sample--instance (Eq a) => Eq (Sample a) where- First == First = True- Second x1 x2 == Second y1 y2 = x1 == y1 && x2 == y2 && True- Third x1 == Third y1 = x1 == y1 && True- _ == _ | length [First{},Second{},Third{}] > 1 = False--test :: Assoced-instance Eq typ => Eq (Assoced typ) where- Assoced x1 x2 == Assoced y1 y2 = x1 == y1 && x2 == y2--test :: TwoParam-instance Eq b => Eq (TwoParam a b) where- TwoParam x1 == TwoParam y1 = x1 == y1---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeEq :: Derivation-makeEq = derivationDSL "Eq" dslEq--dslEq =- List [Instance ["Eq"] "Eq" (List [App "InsDecl" (List [App- "FunBind" (List [Concat (List [MapCtor (App "Match" (List [App- "Symbol" (List [String "=="]),List [App "PApp" (List [App "UnQual"- (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List- [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]- )]))]),App "PApp" (List [App "UnQual" (List [App "Ident" (List [- CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat- (List [String "y",ShowInt FieldIndex])])]))])],App "Nothing" (List- []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App- "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String- "&&"])])]),Tail])) (Concat (List [MapField (App "InfixApp" (List [- App "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (- List [String "x",ShowInt FieldIndex])])])]),App "QVarOp" (List [- App "UnQual" (List [App "Symbol" (List [String "=="])])]),App- "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [- String "y",ShowInt FieldIndex])])])])])),List [App "Con" (List [- App "UnQual" (List [App "Ident" (List [String "True"])])])]]))]),- App "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
− Data/Derive/Fold.hs
@@ -1,66 +0,0 @@--- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>--{-|- A pseudo derivation. Derive a (non-recursive) fold function for - the type which takes one function per alternative constructor. Each- function takes the same arguments as the constructor and returns- a value. When applied to a value the fold function applies the- function for the matching constructor to the constructor fields.- This provides a first-class alternative to pattern matching to- deconstruct the data type.--}-module Data.Derive.Fold(makeFold) where-{--test :: Computer--foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a-foldComputer f _ (Laptop x1 x2) = f x1 x2-foldComputer _ f (Desktop x1) = f x1--test :: Assoced--foldAssoced :: (typ -> String -> a) -> Assoced typ -> a-foldAssoced f (Assoced x1 x2) = f x1 x2--test :: Either--foldEither :: (a -> c) -> (b -> c) -> Either a b -> c-foldEither f _ (Left x1) = f x1-foldEither _ f (Right x1) = f x1--test :: Bool--foldBool :: a -> a -> Bool -> a-foldBool f _ False = f-foldBool _ f True = f---}--import Language.Haskell-import Data.Derive.Internal.Derivation-import Data.List-import Data.Generics.Uniplate.DataOnly---makeFold :: Derivation-makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d---mkFold :: DataDecl -> [Decl]-mkFold d = [TypeSig sl [name n] (foldType d), FunBind $ zipWith f [0..] $ dataDeclCtors d]- where- n = "fold" ++ title (dataDeclName d)- f i c = Match sl (name n) pat Nothing (UnGuardedRhs bod) (BDecls [])- where pat = replicate i PWildCard ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) PWildCard ++- [PParen $ PApp (qname $ ctorDeclName c) (map pVar vars)]- bod = apps (var "f") (map var vars)- vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]---foldType :: DataDecl -> Type-foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]- where- dt = dataDeclType d- v = head $ map (tyVar . return) ['a'..] \\ universe dt- f c = TyParen $ tyFun $ map (fromBangType . snd) (ctorDeclFields c) ++ [v]-
− Data/Derive/Foldable.hs
@@ -1,55 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}--module Data.Derive.Foldable(makeFoldable, makeFoldableN) where--{--import Data.Foldable(Foldable)-import qualified Data.Foldable(foldr)--test :: FailList-instance Foldable (FailList t1) where- foldr _ b Zoro = b- foldr _ b (Fail _) = b- foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2)--test :: Sample-instance Foldable Sample where- foldr _ b First = b- foldr _f b (Second a1 a2) = _f a1 (_f a2 b)- foldr _f b (Third a1) = _f a1 b--test :: Either-instance Foldable (Either t1) where- foldr _ b (Left _) = b- foldr _f b (Right a1) = _f a1 b--}--import Data.Derive.Internal.Traversal-import Data.Derive.Internal.Derivation-import Language.Haskell---makeFoldable :: Derivation-makeFoldable = makeFoldableN 1--makeFoldableN :: Int -> Derivation-makeFoldableN n = traversalDerivation1 foldrTraversal{traversalArg = n} "Foldable"--foldrTraversal = defaultTraversalType- { traversalName = Qual (ModuleName "Data.Foldable") (Ident "foldr")- , traversalFunc = \n a -> appP (var "flip") $ appP (Var n) a- , traversalPlus = fail "variable used in multiple positions in a data type"- , traversalId = App (var "flip") (var "const")- , traverseTuple = foldr (.:) $ var "id"- , traverseCtor = const $ foldr (.:) $ var "id"- , traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pVar "b", pat] Nothing (UnGuardedRhs $ appP rhs (var "b")) (BDecls [])- }- where a .: b = InfixApp (paren a) (qvop ".") (paren b)
− Data/Derive/From.hs
@@ -1,64 +0,0 @@-{-|- A pseudo derivation. For each constructor in the data type,- deriving @From@ generates @from@/CtorName/ which extracts the- components if given the appropriate constructor, and crashes- otherwise. Unlike the DrIFT @\"From\"@ derivation, our version- works for all constructors - zero-arity constructors always return- @()@, arity-one constructors return the contained value, and all- others return a tuple with all the components.--}--module Data.Derive.From(makeFrom) where--{---test :: Sample--fromFirst :: Sample a -> ()-fromFirst First = ()-fromFirst _ = error "fromFirst failed, not a First"--fromSecond :: Sample a -> (a, a)-fromSecond (Second x1 x2) = (x1,x2)-fromSecond _ = error "fromSecond failed, not a Second"--fromThird :: Sample a -> a-fromThird (Third x1) = x1-fromThird _ = error "fromThird failed, not a Third"---}--import Language.Haskell-import Data.Derive.Internal.Derivation---makeFrom :: Derivation-makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d---makeFromCtor :: DataDecl -> CtorDecl -> [Decl]-makeFromCtor d c = [TypeSig sl [name from] typ, FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]- 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-- defMatch = Match sl (name from) [PWildCard] Nothing (UnGuardedRhs err) (BDecls [])- err = App (var "error") $ Lit $ String $ from ++ " failed, not a " ++ n---tyTuple [] = TyCon $ Special UnitCon-tyTuple [x] = x-tyTuple xs = TyTuple Boxed xs---valTuple [] = Con $ Special UnitCon-valTuple [x] = x-valTuple xs = Tuple xs
− Data/Derive/Functor.hs
@@ -1,62 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- NOTE: Cannot be guessed as it relies on type information---- | Derives 'Functor', as discussed on the Haskell-prime mailing list:--- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.-module Data.Derive.Functor(makeFunctor,makeFunctorN) where--{--import Prelude--test :: FailList-instance Functor (FailList t1) where- fmap _ Zoro = Zoro- fmap _ (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 _ First = First- fmap _f (Second a1 a2) = Second (_f a1) (_f a2)- fmap _f (Third a1) = Third (_f a1)--}---import Data.Derive.Internal.Traversal-import Data.Derive.Internal.Derivation-import Language.Haskell---makeFunctor :: Derivation-makeFunctor = makeFunctorN 1--makeFunctorN :: Int -> Derivation-makeFunctorN n = traversalDerivation1 functorTraversal{traversalArg = n} "Functor"--functorTraversal = defaultTraversalType- { traversalName = qname "fmap"- , traverseArrow = Just functorForArrowType- , traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) (BDecls [])- }--functorForArrowType :: Exp -> Exp -> Exp-functorForArrowType a b- | isId a && isId b = var "id"- | isId a = LeftSection b (qvop ".")- | isId b = RightSection (qvop ".") a- | otherwise = Lambda sl [pVar "arg"] $ b .: var "arg" .: a- where isId = (var "id" ==)- a .: b = InfixApp (paren a) (qvop ".") (paren b)
− Data/Derive/Has.hs
@@ -1,40 +0,0 @@-{-|- Has is a pseudo derivation. For each field of any constructor of- the data type, Has generates @has@/FieldName/ which returns 'True'- if given the the given field is a member of the constructor of the- passed object, and 'False' otherwise.--}-module Data.Derive.Has(makeHas) where--{--test :: Computer--hasSpeed :: Computer -> Bool-hasSpeed _ = True--hasWeight :: Computer -> Bool-hasWeight Laptop{} = True-hasWeight _ = False--test :: Sample--}--import Language.Haskell-import Data.Derive.Internal.Derivation-import Data.List---makeHas :: Derivation-makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d---makeHasField :: DataDecl -> String -> [Decl]-makeHasField d field = [TypeSig sl [name has] typ, binds has ms]- where- has = "has" ++ title field- typ = TyFun (dataDeclType d) (tyCon "Bool")- (yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d- match pat val = ([pat], con val)-- ms | null no = [match PWildCard "True"]- | otherwise = [match (PRec (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match PWildCard "False"]
− Data/Derive/Instance/Arities.hs
@@ -1,15 +0,0 @@--- GENERATED START-{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}--module Data.Derive.Instance.Arities where--import Data.Derive.Class.Arities-import Data.Derive.Internal.Instance-- -instance (Data d_type) => Arities d_type where- arities _- = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |- d_ctor <- d_dataCtors (undefined :: d_type)]---- GENERATED STOP
− Data/Derive/Internal/Derivation.hs
@@ -1,49 +0,0 @@--module Data.Derive.Internal.Derivation(- Derivation(..),- derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,- customSplice, customContext- ) where--import Data.DeriveDSL-import Data.Derive.DSL.HSE-import Data.Generics.Uniplate.DataOnly---data Derivation = Derivation- {derivationName :: String- ,derivationOp :: Type -> (String -> Decl) -> FullDataDecl -> Either String [Decl]- }---derivationParams :: String -> ([Type] -> (String -> Decl) -> FullDataDecl -> Either String [Decl]) -> Derivation-derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs---derivationCustom :: String -> (FullDataDecl -> Either String [Decl]) -> Derivation-derivationCustom name op = derivationParams name $ \ty grab decs -> op decs---derivationDSL :: String -> DSL -> Derivation-derivationDSL name dsl = derivationCustomDSL name (const id) dsl---derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation-derivationCustomDSL name custom dsl = derivationCustom name $- \d -> case applyDSL dsl $ snd d of- Left x -> Left x- Right x -> Right $ simplify $ custom d x---customSplice :: (FullDataDecl -> Exp -> Exp) -> (FullDataDecl -> [Decl] -> [Decl])-customSplice custom d = transformBi f- where- f (SpliceExp (ParenSplice x)) = custom d x- f x = x---customContext :: (FullDataDecl -> Context -> Context) -> (FullDataDecl -> [Decl] -> [Decl])-customContext custom d = map f- where- f (InstDecl sl ctx a b c) = InstDecl sl (custom d ctx) a b c- f x = x
− Data/Derive/Internal/Instance.hs
@@ -1,35 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--module Data.Derive.Internal.Instance(- Data, d_ctorArity, d_ctorValue, d_dataCtors- ) where--import Data.Data-import Control.Monad-import Control.Monad.Trans.State---data Ctor = Ctor- {ctorType :: Box- ,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
− Data/Derive/Internal/Traversal.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE CPP #-}-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- NOTE: Cannot be guessed as it relies on type information---- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:--- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>. -module Data.Derive.Internal.Traversal(- TraveralType(..), defaultTraversalType,- traversalDerivation1,- traversalInstance, traversalInstance1,- deriveTraversal- ) where--import Language.Haskell-import Data.Derive.Internal.Derivation-import Data.List-import qualified Data.Set as S-import Control.Monad.Trans.Writer-import Control.Applicative-import Data.Generics.Uniplate.DataOnly-import Data.Maybe----------------------------------------------------------------------------------- --- 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 = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm) - where className n = nm ++ (if n > 1 then show n else "")----- | Instance for a Traversable like class with just 1 method-traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl]-traversalInstance1 tt nm (_,dat)- | isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"- | dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"- | otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]----- | Instance for a Traversable like class-traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances Decl] -> [Decl]-traversalInstance tt nameBase dat bodyM = [simplify $ InstDecl sl 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
− Data/Derive/Is.hs
@@ -1,33 +0,0 @@-module Data.Derive.Is(makeIs) where-{---test :: Sample--isFirst :: Sample a -> Bool-isFirst (First{}) = True ; isFirst _ = False--isSecond :: Sample a -> Bool-isSecond (Second{}) = True ; isSecond _ = False--isThird :: Sample a -> Bool-isThird (Third{}) = True ; isThird _ = False---}--import Language.Haskell-import Data.Derive.Internal.Derivation---makeIs :: Derivation-makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d---makeIsCtor :: DataDecl -> CtorDecl -> [Decl]-makeIsCtor d c =- [TypeSig sl [name nam] (dataDeclType d `TyFun` tyCon "Bool")- ,FunBind $ match : [defMatch | length (dataDeclCtors d) > 1]]- where- nam = "is" ++ ctorDeclName c- - match = Match sl (name nam) [PParen $ PRec (qname $ ctorDeclName c) []] Nothing (UnGuardedRhs $ con "True") (BDecls [])- defMatch = Match sl (name nam) [PWildCard] Nothing (UnGuardedRhs $ con "False") (BDecls [])
− Data/Derive/JSON.hs
@@ -1,165 +0,0 @@--- |--- Copyright: (c) Bertram Felgenhauer 2009--- License: BSD3--- Stability: experimental--- Portability: portable------ Derive 'Text.JSON' instances.------ Unlike Text.JSON.Generics, single constructor types are /not/ handled--- specially. Every value is encoded as an object with a single field,--- with the constructor name as key and the values as its contents.------ If the constructor is a record, the contents is an Object with the--- field names as keys. Otherwise, the contents is an array.--module Data.Derive.JSON (makeJSON) where--import qualified Language.Haskell as H-import Language.Haskell (- Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, BangType, Stmt,- (~=), var, pVar, con, strE, strP, apps, qname, sl,- ctorDeclFields, ctorDeclName, dataDeclCtors)--{--import "json" Text.JSON-import Text.JSON.Types--example :: Custom-instance JSON a => JSON (Sample a) where- readJSON (JSObject x) = $(readJSON)- readJSON _ = Error "..."- showJSON (First) = $(showJSON 0)- showJSON (Second x1 x2) = $(showJSON 1)- showJSON (Third x1) = $(showJSON 2)--}---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeJSON :: Derivation-makeJSON = derivationCustomDSL "JSON" custom $- List [Instance ["JSON"] "JSON" (List [App "InsDecl" (List [App- "FunBind" (List [List [App "Match" (List [App "Ident" (List [- String "readJSON"]),List [App "PParen" (List [App "PApp" (List [- App "UnQual" (List [App "Ident" (List [String "JSObject"])]),List- [App "PVar" (List [App "Ident" (List [String "x"])])]])])],App- "Nothing" (List []),App "UnGuardedRhs" (List [App "SpliceExp" (- List [App "ParenSplice" (List [App "Var" (List [App "UnQual" (List- [App "Ident" (List [String "readJSON"])])])])])]),App "BDecls" (- List [List []])]),App "Match" (List [App "Ident" (List [String- "readJSON"]),List [App "PWildCard" (List [])],App "Nothing" (List- []),App "UnGuardedRhs" (List [App "App" (List [App "Con" (List [- App "UnQual" (List [App "Ident" (List [String "Error"])])]),App- "Lit" (List [App "String" (List [String "..."])])])]),App "BDecls"- (List [List []])])]])]),App "InsDecl" (List [App "FunBind" (List [- MapCtor (App "Match" (List [App "Ident" (List [String "showJSON"])- ,List [App "PParen" (List [App "PApp" (List [App "UnQual" (List [- App "Ident" (List [CtorName])]),MapField (App "PVar" (List [App- "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])])]))]- )])],App "Nothing" (List []),App "UnGuardedRhs" (List [App- "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App- "Var" (List [App "UnQual" (List [App "Ident" (List [String- "showJSON"])])]),App "Lit" (List [App "Int" (List [CtorIndex])])])- ])])]),App "BDecls" (List [List []])]))])])])]--- GENERATED STOP---- ^ 'Derivation' for 'JSON'--custom :: FullDataDecl -> [Decl] -> [Decl]-custom = customSplice splice--splice :: FullDataDecl -> Exp -> Exp-splice d x | x ~= "readJSON" = mkRead d-splice d (H.App x (H.Lit (H.Int y))) | x~= "showJSON" = mkShow d y-splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e----------------------------------------------------------------------------------- showJSON--mkShow :: FullDataDecl -> Integer -> Exp-mkShow d y = let- hasFields = any (not . null . fst) (ctorDeclFields c)- c = dataDeclCtors (snd d) !! fromInteger y- mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields- in- mkJSObject $ H.List- [H.Tuple [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]--mkShowPlainFields :: FieldDecl -> Exp-mkShowPlainFields fs = mkJSArray $ H.List- [var "showJSON" `H.App` xi | xi <- vars "x" fs]--mkShowRecordFields :: FieldDecl -> Exp-mkShowRecordFields fs = mkJSObject $ H.List- [ H.Tuple [strE fn, var "showJSON" `H.App` xi]- | ((fn, _), xi) <- zip fs (vars "x" fs)]----------------------------------------------------------------------------------- readJSON--mkRead :: FullDataDecl -> Exp-mkRead (_, d) = let- readError = con "Error" `H.App` strE "malformed JSON for type ...: ..."- in- H.Case (var "fromJSObject" `H.App` var "x") $- map mkReadCtor (dataDeclCtors d) ++- [H.Alt H.sl H.PWildCard (H.UnGuardedAlt readError) (H.BDecls [])]--mkReadCtor :: CtorDecl -> Alt-mkReadCtor c = let- cn = ctorDeclName c- fs = ctorDeclFields c- hasFields = any (not . null . fst) fs- body | hasFields = mkReadRecord cn fs- | otherwise = mkReadPlain cn fs- in- H.Alt sl (H.PList [H.PTuple [strP cn, pVar "y"]])- (H.UnGuardedAlt body) (H.BDecls [])--mkReadRecord :: String -> FieldDecl -> Exp-mkReadRecord cn fs = H.Do $- [H.Generator sl (H.PApp (qname "JSObject") [pVar "z"])- (var "return" `H.App` var "y")] ++- [H.LetStmt $ H.BDecls [H.PatBind sl (pVar "d") Nothing- (H.UnGuardedRhs $ var "fromJSObject" `H.App` var "z")- (H.BDecls [])]] ++- zipWith (mkReadRecordField cn) (pVars "x" fs) fs ++- mkReadTrailer cn fs--mkReadRecordField :: String -> Pat -> (String, BangType) -> Stmt-mkReadRecordField cn xi (fn, _) = H.Generator sl xi $- apps (var "maybe") [- var "fail" `H.App` strE (unwords ["readJSON: missing field", fn,- "while decoding a", cn]),- var "return",- apps (var "lookup") [strE fn, var "d"]]--mkReadPlain :: String -> FieldDecl -> Exp-mkReadPlain cn fs = H.Do $- [H.Generator sl (H.PApp (qname "JSArray") [H.PList (pVars "x" fs)])- (var "return" `H.App` var "y")] ++- mkReadTrailer cn fs--mkReadTrailer :: String -> FieldDecl -> [Stmt]-mkReadTrailer cn fs =- [ H.Generator sl yi (var "readJSON" `H.App` xi)- | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] ++- [H.Qualifier $ var "return" `H.App` apps (con cn) (vars "y" fs)]----------------------------------------------------------------------------------- utilites--mkJSObject :: Exp -> Exp-mkJSObject e = con "JSObject" `H.App` (var "toJSObject" `H.App` e)--mkJSArray :: Exp -> Exp-mkJSArray e = con "JSArray" `H.App` e--vars :: String -> FieldDecl -> [Exp]-vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]--pVars :: String -> FieldDecl -> [Pat]-pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
− Data/Derive/LazySet.hs
@@ -1,38 +0,0 @@-{-|- A pseudo derivation. For each field in the data type, deriving- @LazySet@ generates a function like a record updator, but lazy where possible.- This is very useful in certain situations to improve laziness- properties. A setter is only lazy if that field is present in one constructor.--}-module Data.Derive.LazySet(makeLazySet) where-{---test :: Computer--setSpeed :: Int -> Computer -> Computer-setSpeed v x = x{speed=v}--setWeight :: Double -> Computer -> Computer-setWeight v x = Laptop v (speed x)--test :: Sample---}--import Language.Haskell-import Data.Derive.Internal.Derivation---makeLazySet :: Derivation-makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d---makeLazySetField :: DataDecl -> String -> [Decl]-makeLazySetField d field = [TypeSig sl [name fun] typ, bind fun [pVar "v",pVar "x"] bod]- where- 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]-- 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")]
− Data/Derive/Monoid.hs
@@ -1,69 +0,0 @@-{-|- Derives an instance of @Monoid@. It uses the product- construction of monoids. @mappend@ on two different constructors- is undefined.--}-module Data.Derive.Monoid(makeMonoid) where-{--import Data.Monoid hiding (First)--example :: Sample-instance Monoid a => Monoid (Sample a) where- mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]- mappend (First) (First) = First- mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)- mappend (Third x1) (Third y1) = Third (mappend x1 y1)- mappend _ _ | length [First{},Second{},Third{}] > 1 = error "Monoid.mappend: Different constructors for Sample"---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeMonoid :: Derivation-makeMonoid = derivationDSL "Monoid" dslMonoid--dslMonoid =- List [Instance ["Monoid"] "Monoid" (List [App "InsDecl" (List [App- "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "mempty"])]),App "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 [Concat (- List [MapCtor (App "Match" (List [App "Ident" (List [String- "mappend"]),List [App "PParen" (List [App "PApp" (List [App- "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App- "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt- FieldIndex])])]))])]),App "PParen" (List [App "PApp" (List [App- "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App- "PVar" (List [App "Ident" (List [Concat (List [String "y",ShowInt- FieldIndex])])]))])])],App "Nothing" (List []),App "UnGuardedRhs"- (List [Application (Concat (List [List [App "Con" (List [App- "UnQual" (List [App "Ident" (List [CtorName])])])],MapField (App- "Paren" (List [Application (List [App "Var" (List [App "UnQual" (- List [App "Ident" (List [String "mappend"])])]),App "Var" (List [- App "UnQual" (List [App "Ident" (List [Concat (List [String "x",- ShowInt FieldIndex])])])]),App "Var" (List [App "UnQual" (List [- App "Ident" (List [Concat (List [String "y",ShowInt FieldIndex])])- ])])])]))]))]),App "BDecls" (List [List []])])),List [App "Match"- (List [App "Ident" (List [String "mappend"]),List [App "PWildCard"- (List []),App "PWildCard" (List [])],App "Nothing" (List []),App- "GuardedRhss" (List [List [App "GuardedRhs" (List [List [App- "Qualifier" (List [App "InfixApp" (List [App "App" (List [App- "Var" (List [App "UnQual" (List [App "Ident" (List [String- "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [- App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])- ,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [- String ">"])])]),App "Lit" (List [App "Int" (List [Int 1])])])])],- App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"- (List [String "error"])])]),App "Lit" (List [App "String" (List [- Concat (List [String "Monoid.mappend: Different constructors for "- ,DataName])])])])])]]),App "BDecls" (List [List []])])]])])])])]--- GENERATED STOP
− Data/Derive/NFData.hs
@@ -1,35 +0,0 @@-module Data.Derive.NFData where-{--import "deepseq" Control.DeepSeq(NFData, rnf)--example :: Sample-instance NFData a => NFData (Sample a) where- rnf (First) = ()- rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()- rnf (Third x1) = rnf x1 `seq` ()---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeNFData :: Derivation-makeNFData = derivationDSL "NFData" dslNFData--dslNFData =- List [Instance ["NFData"] "NFData" (List [App "InsDecl" (List [App- "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [- String "rnf"]),List [App "PParen" (List [App "PApp" (List [App- "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App- "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt- FieldIndex])])]))])])],App "Nothing" (List []),App "UnGuardedRhs"- (List [Fold (App "InfixApp" (List [Head,App "QVarOp" (List [App- "UnQual" (List [App "Ident" (List [String "seq"])])]),Tail])) (- Concat (List [MapField (App "App" (List [App "Var" (List [App- "UnQual" (List [App "Ident" (List [String "rnf"])])]),App "Var" (- List [App "UnQual" (List [App "Ident" (List [Concat (List [String- "x",ShowInt FieldIndex])])])])])),List [App "Con" (List [App- "Special" (List [App "UnitCon" (List [])])])]]))]),App "BDecls" (- List [List []])]))])])])]--- GENERATED STOP
− Data/Derive/Ord.hs
@@ -1,93 +0,0 @@-module Data.Derive.Ord where-{--import Prelude--example :: Sample-instance Ord a => Ord (Sample a) where- compare a b = check a b- where- check (First) (First) = EQ- check (Second x1 x2) (Second y1 y2) = compare x1 y1 & 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)-- EQ & x = x- x & _ = x-- tag (First{}) = 0 :: Int- tag (Second{}) = 1 :: Int- tag (Third{}) = 2 :: Int---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeOrd :: Derivation-makeOrd = derivationDSL "Ord" dslOrd--dslOrd =- List [Instance ["Ord"] "Ord" (List [App "InsDecl" (List [App- "FunBind" (List [List [App "Match" (List [App "Ident" (List [- String "compare"]),List [App "PVar" (List [App "Ident" (List [- String "a"])]),App "PVar" (List [App "Ident" (List [String "b"])])- ],App "Nothing" (List []),App "UnGuardedRhs" (List [Application (- List [App "Var" (List [App "UnQual" (List [App "Ident" (List [- String "check"])])]),App "Var" (List [App "UnQual" (List [App- "Ident" (List [String "a"])])]),App "Var" (List [App "UnQual" (- List [App "Ident" (List [String "b"])])])])]),App "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- "ExpTypeSig" (List [App "Lit" (List [App "Int" (List [CtorIndex])]- ),App "TyCon" (List [App "UnQual" (List [App "Ident" (List [String- "Int"])])])])]),App "BDecls" (List [List []])]))])]])])]])])])]--- GENERATED STOP
− Data/Derive/Read.hs
@@ -1,199 +0,0 @@-{-|- Derives @Read@. This is as defined by the Haskell report, except- there is no support for infix constructors. If you attempt to- derive @Read@ for a data type with infix constructors, the- constructors are handled as if they were prefix constructors, using- the @(@/consym/@)@ syntax.--}-module Data.Derive.Read(makeRead) where--{--import Prelude--example :: Custom-instance Read a => Read (Sample a) where- readsPrec p0 r = - readParen $(bracket 0) (\r0 -> $(comp 0 First )) r ++- readParen $(bracket 1) (\r0 -> $(comp 1 Second)) r ++- readParen $(bracket 2) (\r0 -> $(comp 2 Third )) r ++- []--test :: Sample-instance Read a => Read (Sample a) where- readsPrec p0 r =- readParen (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 _ r =- readParen False (\r0 ->- [ (Laptop x1 x2, r10)- | ("Laptop", r1) <- lex r0- , ("{", r2) <- lex r1- , ("weight", r3) <- lex r2- , ("=", r4) <- lex r3- , (x1, r5) <- readsPrec 0 r4- , (",", r6) <- lex r5- , ("speed", r7) <- lex r6- , ("=", r8) <- lex r7- , (x2, r9) <- readsPrec 0 r8- , ("}", r10) <- lex r9]) r- ++- readParen False (\r0 ->- [ (Desktop x1, r6)- | ("Desktop", r1) <- lex r0- , ("{", r2) <- lex r1- , ("speed", r3) <- lex r2- , ("=", r4) <- lex r3- , (x1, r5) <- readsPrec 0 r4- , ("}", r6) <- lex r5]) r--test :: (:*:)-instance (Read a, Read b) => Read ((:*:) a b) where- readsPrec p0 r =- readParen (p0 > 10) (\r0 ->- [ ((:*:) x1 x2, r3)- | ("(:*:)", r1) <- lex r0- , (x1, r2) <- readsPrec 11 r1- , (x2, r3) <- readsPrec 11 r2]) r---}-import Data.Derive.DSL.HSE-import qualified Language.Haskell as H---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeRead :: Derivation-makeRead = derivationCustomDSL "Read" custom $- List [Instance ["Read"] "Read" (List [App "InsDecl" (List [App- "FunBind" (List [List [App "Match" (List [App "Ident" (List [- String "readsPrec"]),List [App "PVar" (List [App "Ident" (List [- Concat (List [String "p",ShowInt (Int 0)])])]),App "PVar" (List [- App "Ident" (List [String "r"])])],App "Nothing" (List []),App- "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Head,App- "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String- "++"])])]),Tail])) (Concat (List [MapCtor (Application (List [App- "Var" (List [App "UnQual" (List [App "Ident" (List [String- "readParen"])])]),App "SpliceExp" (List [App "ParenSplice" (List [- App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"- (List [String "bracket"])])]),App "Lit" (List [App "Int" (List [- CtorIndex])])])])]),App "Paren" (List [App "Lambda" (List [List [- App "PVar" (List [App "Ident" (List [Concat (List [String "r",- ShowInt (Int 0)])])])],App "SpliceExp" (List [App "ParenSplice" (- List [Application (List [App "Var" (List [App "UnQual" (List [App- "Ident" (List [String "comp"])])]),App "Lit" (List [App "Int" (- List [CtorIndex])]),App "Con" (List [App "UnQual" (List [App- "Ident" (List [CtorName])])])])])])])]),App "Var" (List [App- "UnQual" (List [App "Ident" (List [String "r"])])])])),List [App- "List" (List [List []])]]))]),App "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 ]--readit ctr = case ctorFields ctr of [] -> norm- fl -> flds fl- where- norm = lK "readParen"- [vr "p0" >: lit (10::Integer),- "r0" ->: runComp (pName . foldr (.) id (map (pRead 11) (ctv ctr 'x'))) (ctp ctr 'x'),- l0 "r"]-- flds f = lK "readParen" - [false,- "r0" ->: runComp (pName . pLex "{" .- foldr (.) id (intersperse (pLex ",")- (zipWith pField (ctv ctr 'x') f)) .- pLex "}") (ctp ctr 'x'),- l0 "r"]-- runComp fn ex = CompE $ fn (\k -> [ NoBindS (tup [ex, vrn 'r' k]) ]) 0-- pArse pat fun ct k = BindS (tup [pat, vrn 'r' (k+1)]) (AppE fun (vrn 'r' k)) : ct (k+1)-- pLex pat = pArse (lit pat) (l0 "lex")-- name = ctorName ctr-- pName | isAlpha (head name) || head name == '_' = pLex name- | otherwise = pLex "(" . pLex name . pLex ")"-- pRead pc pat = pArse pat (l1 "readsPrec" (lit (pc :: Integer)))-- pField pat fld = pLex fld . pLex "=" . pRead 0 pat--}
− Data/Derive/Ref.hs
@@ -1,42 +0,0 @@-{-|- A pseudo derivation. For each field in the data type, deriving- @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =- \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.-- This is intended for use with the compositional functional references- described in- <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.--}-module Data.Derive.Ref(makeRef) where--{--test :: Sample--test :: Computer--refSpeed :: Ref Computer-refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}--refWeight :: Ref Computer-refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}--}--import Language.Haskell-import Data.Derive.Internal.Derivation---makeRef :: Derivation-makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d---makeRefField :: DataDecl -> String -> [Decl]-makeRefField d field = [TypeSig sl [name ref] typ, bind ref [] bod]- where- ref = "ref" ++ title field- typ = TyApp (tyCon "Ref") (dataDeclType d)-- bod = RecConstr (qname "Ref")- [FieldUpdate (qname "select") (var field)- ,FieldUpdate (qname "update") $ Lambda sl [pVar "f",pVar "v"] $- RecUpdate (var "v") [FieldUpdate (qname field) $ App (var "f") $ Paren $ App (var field) (var "v")]- ]
− Data/Derive/Serial.hs
@@ -1,66 +0,0 @@-module Data.Derive.Serial where-{--import "smallcheck" Test.SmallCheck--example :: Sample--instance Serial a => Serial (Sample a) where- series = cons0 First \/- cons2 Second \/- cons1 Third-- coseries rs d = [ \t -> case t of- First -> t0- Second x1 x2 -> t1 x1 x2- Third x1 -> t2 x1- | t0 <- alts0 rs d `const` First{}- , t1 <- alts2 rs d `const` Second{}- , t2 <- alts1 rs d `const` Third{}- ]---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeSerial :: Derivation-makeSerial = derivationDSL "Serial" dslSerial--dslSerial =- List [Instance ["Serial"] "Serial" (List [App "InsDecl" (List [App- "PatBind" (List [App "PVar" (List [App "Ident" (List [String- "series"])]),App "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
− Data/Derive/Serialize.hs
@@ -1,134 +0,0 @@-module Data.Derive.Serialize where-{--import "cereal" Data.Serialize--example :: Sample--instance Serialize alpha => Serialize (Sample alpha) where- put x = case x of- First -> do putTag 0- Second x1 x2 -> do putTag 1 ; put x1 ; put x2- Third x1 -> do putTag 2 ; put x1- where- useTag = length [First{}, Second{}, Third{}] > 1- putTag x = when useTag (putWord8 x)-- get = do- i <- getTag- case i of- 0 -> do return (First)- 1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)- 2 -> do x1 <- get ; return (Third x1)- _ -> error "Corrupted binary data for Sample"- where- useTag = length [First{}, Second{}, Third{}] > 1- getTag = if useTag then getWord8 else return 0---test :: List--instance Serialize a => Serialize (List a) where- put x = case x of- Nil -> putWord8 0- Cons x1 x2 -> do putWord8 1; put x1; put x2-- get = do- i <- getWord8- case i of- 0 -> return Nil- 1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)- _ -> error "Corrupted binary data for List"--test :: Assoced--instance Serialize typ => Serialize (Assoced typ) where- put (Assoced x1 x2) = do put x1; put x2- get = do x1 <- get; x2 <- get; return (Assoced x1 x2)----}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeSerialize :: Derivation-makeSerialize = derivationDSL "Serialize" dslSerialize--dslSerialize =- List [Instance ["Serialize"] "Serialize" (List [App "InsDecl" (- List [App "FunBind" (List [List [App "Match" (List [App "Ident" (- List [String "put"]),List [App "PVar" (List [App "Ident" (List [- String "x"])])],App "Nothing" (List []),App "UnGuardedRhs" (List [- App "Case" (List [App "Var" (List [App "UnQual" (List [App "Ident"- (List [String "x"])])]),MapCtor (App "Alt" (List [App "PApp" (List- [App "UnQual" (List [App "Ident" (List [CtorName])]),MapField (App- "PVar" (List [App "Ident" (List [Concat (List [String "x",ShowInt- FieldIndex])])]))]),App "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
− Data/Derive/Set.hs
@@ -1,40 +0,0 @@-{-|- A pseudo derivation. For each field in the data type, deriving- @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.- This derivation is intended to work around the fact that in Haskell- assigning to a field is not a first class object (although- extracting from a field is).--}-module Data.Derive.Set(makeSet) where--{---test :: Computer--setSpeed :: Int -> Computer -> Computer-setSpeed v x = x{speed=v}--setWeight :: Double -> Computer -> Computer-setWeight v x = x{weight=v}--test :: Sample---}--import Language.Haskell-import Data.Derive.Internal.Derivation-import Data.Maybe---makeSet :: Derivation-makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d---makeSetField :: DataDecl -> String -> [Decl]-makeSetField d field = [TypeSig sl [name set] typ, bind set [pVar "v",pVar "x"] bod]- where- set = "set" ++ title field- typ = typField `TyFun` (dataDeclType d `TyFun` dataDeclType d)- typField = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d-- bod = RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]
− Data/Derive/Show.hs
@@ -1,90 +0,0 @@---- | Derives @Show@. This is as defined by the Haskell report, except--- there is no support for infix constructors. If you attempt to--- derive @Show@ for a data type with infix constructors, the--- constructors are handled as if they were prefix constructors, using--- the @(@/consym/@)@ syntax.-module Data.Derive.Show(makeShow) where--{--import Prelude--example :: Custom-instance Show a => Show (Sample a) where- showsPrec p (First) = $(show 0)- showsPrec p (Second x1 x2) = $(show 1)- showsPrec p (Third x1) = $(show 2)---test :: Sample-instance Show a => Show (Sample a) where- showsPrec _ First = showString "First"- showsPrec p (Second x1 x2) = showParen (p > 10) $ showString "Second " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2- showsPrec p (Third x1) = showParen (p > 10) $ showString "Third " . showsPrec 11 x1--test :: Computer-instance Show Computer where- showsPrec _ (Laptop x1 x2) =- showString "Laptop {weight = " . showsPrec 0 x1 . showString ", speed = " . showsPrec 0 x2 . showChar '}'- showsPrec _ (Desktop x1) =- showString "Desktop {speed = " . showsPrec 0 x1 . showChar '}'--test :: (:*:)-instance (Show a, Show b) => Show ((:*:) a b) where- showsPrec p ((:*:) x1 x2) = showParen (p > 10) $ showString "(:*:) " . showsPrec 11 x1 . showChar ' ' . showsPrec 11 x2--}--import Data.List-import Data.Derive.DSL.HSE-import qualified Language.Haskell as H---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeShow :: Derivation-makeShow = derivationCustomDSL "Show" custom $- List [Instance ["Show"] "Show" (List [App "InsDecl" (List [App- "FunBind" (List [MapCtor (App "Match" (List [App "Ident" (List [- String "showsPrec"]),List [App "PVar" (List [App "Ident" (List [- String "p"])]),App "PParen" (List [App "PApp" (List [App "UnQual"- (List [App "Ident" (List [CtorName])]),MapField (App "PVar" (List- [App "Ident" (List [Concat (List [String "x",ShowInt FieldIndex])]- )]))])])],App "Nothing" (List []),App "UnGuardedRhs" (List [App- "SpliceExp" (List [App "ParenSplice" (List [App "App" (List [App- "Var" (List [App "UnQual" (List [App "Ident" (List [String "show"]- )])]),App "Lit" (List [App "Int" (List [CtorIndex])])])])])]),App- "BDecls" (List [List []])]))])])])]--- GENERATED STOP---- Left is a literal string, Right is a variable--custom = customSplice splice--splice :: FullDataDecl -> Exp -> Exp-splice d (H.App x (H.Lit (H.Int y))) | x ~= "show" = combine $ compress $- if fields then customFields c else customPlain c- where- fields = any (not . null . fst) (ctorDeclFields c)- c = dataDeclCtors (snd d) !! fromInteger y-- out (Left [x]) = H.App (var "showChar") (H.Lit $ H.Char x)- out (Left xs ) = H.App (var "showString") (H.Lit $ H.String xs)- out (Right x) = apps (var "showsPrec") [H.Lit $ H.Int (fields ? 0 $ 11), var $ 'x' : show x]-- compress (Left x:Left y:z) = compress $ Left (x++y) : z- compress (x:y) = x : compress y- compress [] = []-- paren = InfixApp (H.App (var "showParen") (Paren $ InfixApp (var "p") (qvop ">") (H.Lit $ H.Int 10))) (qvop "$")- combine xs = (fields || or [' ' `notElem` x | Left x <- xs] ? id $ paren) $- foldr1 (\x y -> InfixApp x (qvop ".") y) $ map out xs---customPlain :: CtorDecl -> [Either String Int]-customPlain c = intersperse (Left " ") $ Left (ctorDeclName c) : map Right [1..length (ctorDeclFields c)]--customFields :: CtorDecl -> [Either String Int]-customFields c = Left (ctorDeclName c ++ " {") : concat (intersperse [Left ", "] xs) ++ [Left "}"]- where xs = [[Left (n ++ " = "), Right i] | (i,(n,t)) <- zip [1..] $ ctorDeclFields c]
− Data/Derive/Traversable.hs
@@ -1,56 +0,0 @@-{-- This module is not written/maintained by the usual Data.Derive author.-- MAINTAINER: Twan van Laarhoven - EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"-- Please send all patches to this module to Neil (ndmitchell -at- gmail),- and CC Twan.--}---- NOTE: Cannot be guessed as it relies on type information--module Data.Derive.Traversable(makeTraversable, makeTraversableN) where--{--import Data.Traversable-import Control.Applicative(pure, (<*>))--instance Traversable (FailList t1) where- traverse _f (Zoro) = pure Nil- traverse _f (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--makeTraversableN :: Int -> Derivation-makeTraversableN n = traversalDerivation1 traverseTraversal{traversalArg = n} "Traversable"--traverseTraversal = defaultTraversalType- { traversalName = qname "traverse"- , traversalId = var "pure"- , traversalPlus = fail "variable used in multiple positions in a data type"- , traverseTuple = \args -> liftAN (Con $ Special $ TupleCon Unboxed $ length args) args- , traverseCtor = \ctor -> liftAN (con ctor)- , traverseFunc = \pat rhs -> Match sl (name "") [pVar "_f", pat] Nothing (UnGuardedRhs rhs) (BDecls [])- }--liftAN :: Exp -> [Exp] -> Exp-liftAN base args = foldl (<*>) (appP (var "pure") base) args- where x <*> y = InfixApp (paren x) (QVarOp $ UnQual $ Symbol "<*>") (paren y)
− Data/Derive/Typeable.hs
@@ -1,96 +0,0 @@-{-|- Derivation for the 'Typeable' class, as described in the Scrap- Your Boilerplate papers. This derivation generates instances for- all kinds of TypeableK classes; as such we do NOT require the- GHC-specific generic downkinding instances to provide lower kind- instances.-- Also creates a @typename_\<the type name\>@ value to hold the- 'TypeRep'.--}-module Data.Derive.Typeable(makeTypeable) where-{--import Data.Typeable--test :: Bool-typename_Bool :: TyCon-typename_Bool = 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--{--#define INSTANCE_TYPEABLE1(tycon,tcname,str) \-tcname = mkTyCon str; \-instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \-instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault }--#define INSTANCE_TYPEABLE2(tycon,tcname,str) \-tcname = mkTyCon str; \-instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \-instance Typeable a => Typeable1 (tycon a) where { \- typeOf1 = typeOf1Default }; \-instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \- typeOf = typeOfDefault }--#define INSTANCE_TYPEABLE3(tycon,tcname,str) \-tcname = mkTyCon str; \-instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \-instance Typeable a => Typeable2 (tycon a) where { \- typeOf2 = typeOf2Default }; \-instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \- typeOf1 = typeOf1Default }; \-instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \- typeOf = typeOfDefault }--}---makeTypeable :: Derivation-makeTypeable = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x---mkTypeable :: String -> DataDecl -> [Decl]-mkTypeable modu d =- [TypeSig sl [name fun] (tyCon "TyCon")] ++- [PatBind sl (pVar fun) 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 = dataDeclName d- fun = "typename_" ++ nam- n = length $ dataDeclVars d---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
− Data/Derive/UniplateDirect.hs
@@ -1,215 +0,0 @@-{-# LANGUAGE PatternGuards #-}--- NOTE: Cannot be guessed as it relies on type information---- | Derive Uniplate and Biplate using the Direct combinators.--- You must specific monomorphic instances, i.e:------ > data Foo a = Foo a Int--- >--- > {-!--- > deriving instance UniplateDirect (Foo Int)--- > deriving instance UniplateDirect (Foo Int) Int--- > !-}------ All types referred to must be in scope at the time.------ @deriving UniplateDirect@ with no arguments will be assumed to derive the Uniplate--- instance on all types being unit.-module Data.Derive.UniplateDirect(makeUniplateDirect) where---{--import "uniplate" Data.Generics.Uniplate.Direct----- test tuples-test :: UniplateDirect ((), Maybe ()) ()-instance Biplate ((), Maybe ()) () where- {-# INLINE biplate #-}- biplate (x1, x2) = plate (,) |* x1 |+ x2--test :: UniplateDirect (Sample Int)-instance Uniplate (Sample Int) where- {-# INLINE uniplate #-}- uniplate x = plate x--test :: UniplateDirect (Sample Int) Int-instance Biplate (Sample Int) Int where- {-# INLINE biplate #-}- biplate (Second x1 x2) = plate Second |* x1 |* x2- biplate (Third x1) = plate Third |* x1- biplate x = plate x--test :: UniplateDirect Computer-instance Uniplate Computer where- {-# INLINE uniplate #-}- uniplate x = plate x--test :: UniplateDirect Computer Computer-instance Biplate Computer Computer where- {-# INLINE biplate #-}- biplate = plateSelf--test :: UniplateDirect Computer Double-instance Biplate Computer Double where- {-# INLINE biplate #-}- biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2- biplate x = plate x--test :: UniplateDirect (Assoced (Maybe Bool)) Char-instance Biplate (Assoced (Maybe Bool)) Char where- {-# INLINE biplate #-}- biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2---- test following external declarations-test :: UniplateDirect (Either Bool Computer) Int-instance Biplate (Either Bool Computer) Int where- {-# INLINE biplate #-}- biplate (Right x1) = plate Right |+ x1- biplate x = plate x---- test recursive bits-test :: UniplateDirect (List Int) Bool-instance Biplate (List Int) Bool where- {-# INLINE biplate #-}- biplate x = plate x--}--import Language.Haskell-import Data.Generics.Uniplate.DataOnly-import Data.Derive.Internal.Derivation-import Data.Maybe-import qualified Data.Map as Map-import Control.Arrow-import Control.Monad.Trans.State---makeUniplateDirect :: Derivation-makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $- let known = map (declName &&& id) knownCtors- grab2 x = fromMaybe (grab x) $ lookup x known- in case args of- _ | not $ null [() | TyVar _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"- [] -> make True grab2 x x- where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon $ Special UnitCon- [x] -> make True grab2 x x- [x,y] -> make False grab2 x y- _ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)- --make :: Bool -> (String -> DataDecl) -> Type -> Type -> Either String [Decl]-make uni grab from to = Right [InstDecl sl [] (UnQual $ Ident $ if uni then "Uniplate" else "Biplate") (from : [to | not uni])- [InsDecl $ InlineSig sl True AlwaysActive (qname $ if uni then "uniplate" else "biplate"), InsDecl ms]]- where- ty = grab $ tyRoot from- match pat bod = Match sl (Ident $ if uni then "uniplate" else "biplate") [pat] Nothing (UnGuardedRhs bod) (BDecls [])- ms = if uni || from /= to- then FunBind $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (var "plate" `App` var "x") | any isNothing bods]- else PatBind sl (pVar "biplate") Nothing (UnGuardedRhs $ var "plateSelf") (BDecls [])- bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty---make1 :: (String -> DataDecl) -> (String,[Type]) -> S (Maybe (Pat, Exp))-make1 grab (name,tys) = do- ops <- mapM (fmap show . operator grab) tys- let vars = ['x':show i | i <- [1..length tys]]- pat = PParen $ PApp (qname name) $ map pVar vars- (good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars- bod = foldl (\x (y,z) -> InfixApp x (QVarOp $ UnQual $ Symbol y) z) (App (var "plate") $ paren $ apps (con name) (map snd good)) bad- return $ if all (== "|-") ops then Nothing else Just (pat,bod)---data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq--instance Show Ans where- show Hit = "|*"- show Miss = "|-"- show Try = "|+"- show ListHit = "||*"- show ListTry = "||+"--ansList Hit = ListHit-ansList Miss = Miss-ansList _ = ListTry---ansJoin (Miss:xs) = ansJoin xs-ansJoin [] = Miss-ansJoin _ = Try---type S a = State (Map.Map Type Ans) a--run :: Type -> S a -> a-run to act = evalState act (Map.singleton to Hit)--operator :: (String -> DataDecl) -> Type -> S Ans-operator grab from = do- mp <- get- case Map.lookup from mp of- Just y -> return y- Nothing -> do- fix Miss- where- fix ans = do- s <- get- modify $ Map.insert from ans- ans2 <- operator2 grab from- if ans == ans2- then return ans- else put s >> fix ans2---operator2 :: (String -> DataDecl) -> Type -> S Ans-operator2 grab from- | isTyFun from = return Try- | Just from2 <- fromTyList from = fmap ansList $ operator grab from2- | otherwise = case subst from $ grab $ tyRoot from of- Left from2 -> operator grab from2- Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs---subst :: Type -> Decl -> Either Type [(String,[Type])]-subst ty x@TypeDecl{} = Left $ substType ty x-subst ty x = Right $ substData ty x--substData :: Type -> Decl -> [(String,[Type])]-substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . fromBangType . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]- where- rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)- f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep- f x = x--substType :: Type -> Decl -> Type-substType ty (TypeDecl _ _ vars d) = fromTyParens $ transform f d- where- rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)- f (TyVar x) = fromMaybe (TyVar x) $ lookup (prettyPrint x) rep- f x = x---knownCtors :: [Decl]-knownCtors = map (fromParseResult . parseDecl)- ["data Int = Int"- ,"data Bool = Bool"- ,"data Char = Char"- ,"data Double = Double"- ,"data Float = Float"- ,"data Integer = Integer"- ,"data Maybe a = Nothing | Just a"- ,"data Either a b = Left a | Right b"- ,"type Rational = Ratio Integer"- ,"data (Integral a) => Ratio a = !a :% !a"- ,"type String = [Char]"- ] ++- listCtor :- map tupleDefn (0:[2..32])--listCtor = DataDecl sl DataType [] (Ident "[]") [UnkindedVar $ Ident "a"]- [QualConDecl sl [] [] $ ConDecl (Ident "[]") []- ,QualConDecl sl [] [] $ ConDecl (Ident "(:)") [UnBangedTy $ tyVar "a", UnBangedTy $ TyList $ tyVar "a"]] []--tupleDefn :: Int -> Decl-tupleDefn n = DataDecl sl DataType [] (Ident s) (map (UnkindedVar . Ident) vars) [QualConDecl sl [] [] $ ConDecl (Ident s) (map (UnBangedTy . tyVar) vars)] []- where s = "(" ++ replicate (n - 1) ',' ++ ")"- vars = ['v':show i | i <- [1..n]]
− Data/Derive/UniplateTypeable.hs
@@ -1,72 +0,0 @@-module Data.Derive.UniplateTypeable where-{--import "uniplate" Data.Generics.Uniplate.Typeable--example :: Custom--instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where- plateAll (First) = plate First- plateAll (Second x1 x2) = plate Second |+ x1 |+ x2- plateAll (Third x1) = plate Third |+ x1--test :: Bool--instance (Typeable to, Uniplate to) => PlateAll Bool to where- plateAll False = plate False- plateAll True = plate True--test :: Either a b--instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where- plateAll (Left x1) = plate Left |+ x1- plateAll (Right x1) = plate Right |+ x1---}--import Data.Derive.DSL.HSE---- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makeUniplateTypeable :: Derivation-makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $- List [App "InstDecl" (List [List [App "ClassA" (List [App "UnQual"- (List [App "Ident" (List [String "Typeable"])]),List [App "TyVar"- (List [App "Ident" (List [String "a"])])]]),App "ClassA" (List [- App "UnQual" (List [App "Ident" (List [String "PlateAll"])]),List- [App "TyVar" (List [App "Ident" (List [String "a"])]),App "TyVar"- (List [App "Ident" (List [String "to"])])]]),App "ClassA" (List [- App "UnQual" (List [App "Ident" (List [String "Uniplate"])]),List- [App "TyVar" (List [App "Ident" (List [String "to"])])]]),App- "ClassA" (List [App "UnQual" (List [App "Ident" (List [String- "Typeable"])]),List [App "TyVar" (List [App "Ident" (List [String- "to"])])]])],App "UnQual" (List [App "Ident" (List [String- "PlateAll"])]),List [App "TyParen" (List [App "TyApp" (List [App- "TyCon" (List [App "UnQual" (List [App "Ident" (List [DataName])])- ]),App "TyVar" (List [App "Ident" (List [String "a"])])])]),App- "TyVar" (List [App "Ident" (List [String "to"])])],List [App- "InsDecl" (List [App "FunBind" (List [MapCtor (App "Match" (List [- App "Ident" (List [String "plateAll"]),List [App "PParen" (List [- App "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName]- )]),MapField (App "PVar" (List [App "Ident" (List [Concat (List [- String "x",ShowInt FieldIndex])])]))])])],App "Nothing" (List []),- App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [Tail,App- "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [String- "|+"])])]),Head])) (Concat (List [Reverse (MapField (App "Var" (- List [App "UnQual" (List [App "Ident" (List [Concat (List [String- "x",ShowInt FieldIndex])])])]))),List [App "App" (List [App "Var"- (List [App "UnQual" (List [App "Ident" (List [String "plate"])])])- ,App "Con" (List [App "UnQual" (List [App "Ident" (List [CtorName]- )])])])]]))]),App "BDecls" (List [List []])]))])])]])]--- GENERATED STOP---custom (_,d) [InstDecl x1 _ x3 _ x5] = [InstDecl x1 x2 x3 x4 x5]- where- vars = dataDeclVars d- dd = (if null vars then id else TyParen) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)- x2 = concatMap f vars ++ [ClassA (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]- x4 = [dd, tyVar "to"]- f v = [ClassA (qname "Typeable") [tyVar v], ClassA (qname "PlateAll") [tyVar v, tyVar "to"]]
− Data/Derive/Update.hs
@@ -1,47 +0,0 @@-{-|- A Pseudo derivation. For every label, creates a function- foo_u and foo_s which updates and sets the label respectively,- e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'--}-module Data.Derive.Update(makeUpdate) where--{---test :: Computer--speed_u :: (Int -> Int) -> Computer -> Computer-speed_u f x = x{speed = f (speed x)}--speed_s :: Int -> Computer -> Computer-speed_s v x = x{speed = v}--weight_u :: (Double -> Double) -> Computer -> Computer-weight_u f x = x{weight = f (weight x)}--weight_s :: Double -> Computer -> Computer-weight_s v x = x{weight = v}--test :: Sample---}--import Language.Haskell-import Data.Derive.Internal.Derivation-import Data.Maybe---makeUpdate :: Derivation-makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d---makeUpdateField :: DataDecl -> String -> [Decl]-makeUpdateField d field =- [TypeSig sl [name upd] (TyParen (TyFun typF typF) `TyFun` typR)- ,bind upd [pVar "f",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (App (var "f") (Paren $ App (var field) (var "x")))]- ,TypeSig sl [name set] (typF `TyFun` typR)- ,bind set [pVar "v",pVar "x"] $ RecUpdate (var "x") [FieldUpdate (qname field) (var "v")]]- where- set = field ++ "_s"- upd = field ++ "_u"- typR = dataDeclType d `TyFun` dataDeclType d- typF = fromBangType $ fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
− Data/DeriveDSL.hs
@@ -1,21 +0,0 @@--module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where--import Data.Derive.DSL.Derive-import Data.Derive.DSL.Apply-import Data.Derive.DSL.DSL-import Data.Derive.DSL.HSE-import Data.Derive.DSL.SYB-import Data.Maybe---deriveDSL :: [Decl] -> Maybe DSL-deriveDSL = listToMaybe . derive---applyDSL :: DSL -> DataDecl -> Either String [Decl]-applyDSL dsl inp = Right $ apply dsl $ toInput inp---dynamicDSL :: DSL -> Maybe [Decl]-dynamicDSL = dslSYB
− Data/DeriveTH.hs
@@ -1,44 +0,0 @@--- | The main TH driver module. It is intended that this need be the--- only module imported by user code; it takes care of all data--- threading issues such that all one needs to do is:------ @--- data Foo = Foo ; $( derive makeEq ''Foo )--- @-module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where--import Control.Monad--import Data.Derive.All-import Data.Derive.Internal.Derivation-import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)-import Language.Haskell as HS-import Language.Haskell.Convert---- | Derive an instance of some class. @derive@ only derives instances--- for the type of the argument.-derive :: Derivation -> TH.Name -> Q [Dec]-derive d name = do- x <- reify name- case x of- TyConI dec -> deriveFromDec d dec- _ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x---derives :: [Derivation] -> [TH.Name] -> Q [Dec]-derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]----- | Derive an instance of some class. @deriveFromDec@ only derives instances--- for the type of the argument.-deriveFromDec :: Derivation -> Dec -> Q [Dec]-deriveFromDec d x = do- x <- liftM normData $ expandData x- let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x- case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of- Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []- Right v -> return $ convert v---toFullDataDecl :: Dec -> FullDataDecl-toFullDataDecl x = (ModuleName "Todo", convert x)
− Derive/Derivation.hs
@@ -1,100 +0,0 @@--module Derive.Derivation(wantDerive, performDerive, writeDerive) where--import System.IO-import System.IO.Unsafe-import Language.Haskell-import Control.Arrow-import Control.Monad-import Data.List-import Derive.Utils-import Derive.Flags-import Data.Derive.All-import Data.Derive.Internal.Derivation-import qualified Data.Map as Map--------------------------------------------------------------------------- WHAT DO YOU WANT TO DERIVE--wantDerive :: [Flag] -> Module -> Module -> [Type]-wantDerive flag real mine = nub $ map fromTyParens $ wantDeriveFlag flag decls ++ wantDeriveAnnotation real mine- where decls = filter isDataDecl $ moduleDecls mine---wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type]-wantDeriveFlag flags decls = [TyApp (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]- where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]--wantDeriveAnnotation :: Module -> Module -> [Type]-wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real---moduleDerives :: Module -> [Type]-moduleDerives = concatMap f . moduleDecls - where- f (DataDecl _ _ _ name vars _ deriv) = g name vars deriv- f (GDataDecl _ _ _ name vars _ _ deriv) = g name vars deriv- f (DerivDecl _ _ name args) = [TyCon name `tyApps` args]- f _ = []-- g name vars deriv = [TyCon a `tyApps` (b:bs) | (a,bs) <- deriv]- where b = TyCon (UnQual name) `tyApps` map (tyVar . prettyPrint) vars--------------------------------------------------------------------------- ACTUALLY DERIVE IT--performDerive :: Module -> [Type] -> [String]-performDerive modu = concatMap ((:) "" . f)- where- grab = getDecl modu-- f ty = case d ty grab (moduleName modu, grab typ1Name) of- Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]- Right x -> concatMap (lines . prettyPrint) x- where- d = derivationOp $ getDerivation clsName- (cls,typ1:_) = fromTyApps ty- clsName = prettyPrint cls- typ1Name = tyRoot typ1- msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x---getDecl :: Module -> (String -> Decl)-getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp- where- mp = Map.fromList $ concatMap f $ moduleDecls modu- f x@(DataDecl _ _ _ name _ _ _) = [(prettyPrint name, x)]- f x@(GDataDecl _ _ _ name _ _ _ _) = [(prettyPrint name, x)]- f x@(TypeDecl _ name _ _) = [(prettyPrint name, x)]- f _ = []---getDerivation :: String -> Derivation-getDerivation = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp- where- mp = Map.fromList $ map (derivationName &&& id) derivations--------------------------------------------------------------------------- WRITE IT BACK--writeDerive :: FilePath -> ModuleName -> [Flag] -> [String] -> IO ()-writeDerive file modu flags xs = do- -- force the output first, ensure that we don't crash half way through- () <- length (concat xs) `seq` return ()- - let append = Append `elem` flags- let output = [x | Output x <- flags]-- let ans = take 1 ["module " ++ x ++ " where" | Modu x <- reverse flags] ++- ["import " ++ if null i then prettyPrint modu else i | Import i <- flags] ++- xs-- when append $ do- src <- readFile' file- writeGenerated file ans-- forM output $ \o -> writeFile o $ unlines ans- when (not append && null output) $ putStr $ unlines ans
− Derive/Flags.hs
@@ -1,63 +0,0 @@--module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where--import System.Environment-import System.Console.GetOpt-import System.Directory-import Language.Haskell-import System.Exit-import System.IO-import Data.Maybe---data Flag = Version | Help | Output String | Import String | Modu String- | Append | Derive [String] | NoOpts | 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
− Derive/Generate.hs
@@ -1,119 +0,0 @@--module Derive.Generate(generate) where--import Language.Haskell.Exts-import Data.DeriveDSL-import Derive.Utils-import Control.Monad-import Data.Maybe-import System.FilePath-import System.Directory-import Data.Char-import Data.List---evil = words $ "TTypeable Uniplate"---- generate extra information for each derivation-generate :: IO ()-generate = do- xs <- getDirectoryContents "Data/Derive"- xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]- lis <- mapM generateFile $ map ("Data/Derive" </>) xs- let names = map dropExtension xs- n = maximum $ map length names- writeGenerated "Data/Derive/All.hs" $- ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] ++- ["derivations :: [Derivation]"- ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]- writeGenerated "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)--
− Derive/Test.hs
@@ -1,98 +0,0 @@--module Derive.Test(test) where--import Derive.Utils-import Data.Derive.DSL.HSE-import Control.Monad-import Data.Maybe-import Data.List-import System.FilePath-import System.Cmd-import System.Exit-import Control.Arrow-import Data.Derive.All-import Data.Derive.Internal.Derivation----- These overlap with other derivations-overlaps =- [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]- ,["Serialize"]]---- REASONS:--- UniplateDirect: Doesn't work through Template Haskell-exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial"]---- These must be first and in every set-priority = ["Eq","Typeable"]---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"- devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]- let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs-- let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $- [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps-- forM sets $ \(i,xs) -> autoTest (name++show i) decls xs- writeFile (name++".hs") $ unlines $- ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]- res <- system $ "runhaskell " ++ name ++ ".hs"- when (res /= ExitSuccess) $ error "Failed to typecheck results"---testFile :: [(String,Decl)] -> Derivation -> IO ()-testFile types (Derivation name op) = do- putStrLn $ "Testing " ++ name- src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"- forM_ (srcTest src) $ \(typ,res) -> do- let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ- let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types- let Right r = op typ grab (ModuleName "Example", grab d)- when (not $ r `outEq` res) $- error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r--detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb- where na = length as ; nb = length bs--detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b- where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)---autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()-autoTest name ts ds =- writeFile (name++".hs") $ unlines $- ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators #-}"- ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"- ,"module " ++ name ++ " where"- ,"import Prelude"- ,"import Data.DeriveTH"- ,"import Derive.TestInstances()"] ++- [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] ++- [prettyPrint t | t <- ts2] ++- ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]- where- types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"- ts2 = filter (not . isBuiltIn) ts--isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
− Derive/Utils.hs
@@ -1,86 +0,0 @@--module Derive.Utils where--import Data.Derive.DSL.HSE-import Data.List-import qualified Data.ByteString.Char8 as BS-import System.Directory-import System.IO-import System.FilePath-import Control.Monad-import Data.Maybe---data Src = Src- {srcName :: String- ,srcImport :: [ImportDecl]- ,srcExample :: Maybe [Decl]- ,srcTest :: [(Type,[Decl])]- ,srcCustom :: Bool- }---- skip the importPkg bits-srcImportStd :: Src -> [ImportDecl]-srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]--nullSrc = Src "" [] Nothing [] False---readHSE :: FilePath -> IO Module-readHSE file = do- src <- readFile' file- src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $- dropWhile (not . isPrefixOf "module ") $ lines src-- let mode = defaultParseMode{extensions=[MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}- return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src---data Pragma = Example Bool | Test Type--asPragma :: Decl -> Maybe Pragma-asPragma (TypeSig _ [x] t)- | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"- | x ~= "test" = Just $ Test t-asPragma _ = Nothing---readSrc :: FilePath -> IO Src-readSrc file = do- modu <- readHSE file- return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}- [ (p,xs)- | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]- , let xs = takeWhile (isNothing . asPragma) real ]- where- f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}- f src (Test x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}---generatedStart = "-- GENERATED START"-generatedStop = "-- GENERATED STOP"----writeGenerated :: FilePath -> [String] -> IO ()-writeGenerated file x = do- src <- fmap lines $ readFile' file- let pre = takeWhile (/= generatedStart) src- post = drop 1 $ dropWhile (/= generatedStop) src- src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post- when (src /= src2) $- seq (length src2) $ writeBinaryFile file $ unlines src2---readFile' :: FilePath -> IO String-readFile' file = do- b <- doesFileExist file- if b then fmap BS.unpack $ BS.readFile file else return []---writeBinaryFile :: FilePath -> String -> IO ()-writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)---rep from to x = if x == from then to else x-reps from to = map (rep from to)
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2009.+Copyright Neil Mitchell 2006-2017. All rights reserved. Redistribution and use in source and binary forms, with or without
− Language/Haskell.hs
@@ -1,293 +0,0 @@--module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where--import Language.Haskell.Exts hiding (var,app,binds,paren)-import Data.List-import Data.Generics.Uniplate.Data-import Data.Data-import Data.Char---infix 1 ?-True ? b = const b-False ? b = id------ insert explicit foralls-foralls :: Type -> Type-foralls x = TyForall (Just $ map UnkindedVar $ nub [y | TyVar y <- universe x]) [] x---tyApps x [] = x-tyApps x (y:ys) = tyApps (TyApp x y) ys---fromTyApps (TyTuple _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)-fromTyApps (TyApp x y) = let (a,b) = fromTyApps x in (a, b ++ [y])-fromTyApps (TyList x) = (TyCon $ Special ListCon, [x])-fromTyApps x = (x, [])--fromTyTuple (TyTuple _ xs) = xs-fromTyTuple x = [x]--fromTyParen (TyParen x) = fromTyParen x-fromTyParen x = x--fromTyParens = transform fromTyParen--tyRoot = prettyPrint . fst . fromTyApps . fromTyParen--isTyFun TyFun{} = True-isTyFun _ = False--isTyParen TyParen{} = True ; isTyParen _ = False--fromTyList (TyList x) = Just x-fromTyList (TyApp (TyCon (Special ListCon)) x) = Just x-fromTyList x = Nothing---x ~= y = prettyPrint x == y---appP x@App{} y = App x y-appP x y = App (paren x) (paren y)---simplify :: Data a => a -> a-simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp- where- fExp (App op (List xs))- | op ~= "length" = Lit $ Int $ fromIntegral $ length xs- | op ~= "head" = head xs- | op ~= "null" = con $ show $ null xs- fExp (InfixApp (Lit (Int i)) op (Lit (Int j)))- | op ~= "-" = Lit $ Int $ i - j- | op ~= "+" = Lit $ Int $ i + j- | op ~= ">" = Con $ UnQual $ Ident $ show $ i > j- fExp (InfixApp x op y)- | op ~= "`const`" = x- | op ~= "&&" && y ~= "True" = x- | x ~= "id" && op ~= "." = y- | y ~= "id" && op ~= "." = x- fExp (InfixApp (Lit (String x)) op (Lit (String y))) | op ~= "++" = Lit $ String $ x ++ y- fExp (App (App (App flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x - fExp (App (Paren x@App{}) y) = fExp $ App x y- fExp (App (Paren (InfixApp x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z- fExp (App op x) | op ~= "id" = x- fExp (App (App flp con) x) | flp ~= "flip" && con ~= "const" = var "id"- fExp (App (App con x) y) | con ~= "const" = x- fExp (App choose (Tuple [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App (var "return") x- fExp (App op x) | op ~= "id" = x- fExp (InfixApp (App when true) dot res)- | when ~= "when" && true ~= "True" = res- fExp (InfixApp x y z) | y ~= "++" && z ~= "[]" = x- fExp (App (LeftSection x op) y) = fExp $ InfixApp x op (paren y)- fExp (Paren x) | isAtom x = x- fExp (Do [Qualifier x]) = x- fExp (Do (Qualifier (App ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do xs- fExp (Do (Generator _ (PVar x) (App ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do $ subst x2 y xs- where x2 = Var $ UnQual x- fExp (Case (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case x alts- fExp (Case (Lit x) alts) | good /= [] = head good- where good = [z | Alt _ (PLit y) (UnGuardedAlt z) (BDecls []) <- alts, y == x]- fExp (If x t f)- | x ~= "True" = t- | x ~= "False" = f- fExp (App (App when b) x)- | when ~= "when" && b ~= "True" = x- | when ~= "when" && b ~= "False" = App (Var $ UnQual $ Ident "return") (Con $ Special $ TupleCon Boxed 0)- fExp (App (Paren (Lambda _ [PVar x] y)) z) | once x2 y = fExp $ subst x2 z y- where x2 = Var $ UnQual x- fExp (App (Paren (Lambda _ [PWildCard] x)) _) = x- fExp (Lambda s ps x) = Lambda s (minPat x ps) x- fExp (Con x) = Con $ rename x- fExp x = x-- fTyp (TyApp x y) | x ~= "[]" = TyList y- fTyp (TyApp (TyCon (Special ListCon)) x) = TyList x- fTyp (TyParen x@TyCon{}) = x- fTyp (TyParen x@TyVar{}) = x- fTyp (TyParen x@TyList{}) = x- fTyp (TyCon nam) = TyCon $ rename nam- fTyp x = x-- fPat (PParen x@(PApp _ [])) = x- fPat (PParen (PParen x)) = PParen x- fPat (PApp nam xs) = case rename nam of- Special (TupleCon Boxed _) -> PTuple xs- nam -> PApp nam xs- fPat (PParen (PTuple xs)) = PTuple 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 o@(Match a b c d e bind) = fBinds (Match a b (minPat o 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 -- minPat o ps = transformBi f ps- where- known = nub [x | UnQual x <- universeBi o]- f (PVar x) | x `notElem` known = PWildCard- f (PAsPat x y) | x `notElem` known = y- f x = x----isGuardFalse (Match sl nam pat sig (GuardedRhss [GuardedRhs _ [Qualifier x] bod]) decls) = x ~= "False"-isGuardFalse _ = False---rename (UnQual (Ident ('(':xs@(x:_))))- | x == ',' = Special $ TupleCon Boxed $ length xs- | x /= ')' = UnQual $ Symbol $ init xs-rename x = x---isAtom Con{} = True-isAtom Var{} = True-isAtom Lit{} = True-isAtom Paren{} = True-isAtom _ = False---paren x = if isAtom x then x else Paren x--sl = SrcLoc "" 0 0--noSl mr = transformBi (const sl) mr---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---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--dataDeclContext :: DataDecl -> Context-dataDeclContext (DataDecl _ _ ctx _ _ _ _) = ctx-dataDeclContext _ = error "dataDeclContext: not a DataDecl"--dataDeclName :: DataDecl -> String-dataDeclName (DataDecl _ _ _ name _ _ _) = prettyPrint name-dataDeclName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name--dataDeclVars :: DataDecl -> [String]-dataDeclVars (DataDecl _ _ _ _ vars _ _) = map 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--declName :: Decl -> String-declName (DataDecl _ _ _ name _ _ _) = prettyPrint name-declName (GDataDecl _ _ _ name _ _ _ _) = prettyPrint name-declName (TypeDecl _ name _ _) = prettyPrint name-
− Language/Haskell/Convert.hs
@@ -1,256 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}--module Language.Haskell.Convert(Convert, convert) where--import Language.Haskell as HS-import Language.Haskell.TH.Syntax as TH-import Control.Exception-import Data.Typeable-import System.IO.Unsafe-import Data.Maybe---class (Typeable a, Typeable b, Show a, Show b) => Convert a b where- conv :: a -> b---convert :: forall a b . Convert a b => a -> b-convert a = unsafePerformIO $- (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)- where- msg e = "Could not convert " ++ show (typeOf a) ++ " to " ++- show (typeOf (undefined :: b)) ++ "\n" ++ show a ++- "\n" ++ show e----appT = 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)- conv (DataDecl _ DataType ctx nam typ cs ds) =- DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds))- conv (DataDecl _ NewType ctx nam typ [con] ds) =- NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds))--instance Convert HS.QualConDecl TH.Con where- conv (QualConDecl _ [] [] con) = c con- conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con)--instance Convert HS.ConDecl TH.Con where- conv (ConDecl nam typ) = NormalC (c nam) (c typ)- conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r)- conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs)--instance Convert HS.BangType TH.StrictType where- conv (BangedTy t) = (IsStrict,c t)- conv (UnBangedTy t) = (NotStrict,c t)--instance Convert ([HS.Name],HS.BangType) [TH.VarStrictType] where- conv (names,bt) = [(c name,s,t) | name <- names]- where (s,t) = c bt--instance Convert HS.Asst TH.Type where- conv (InfixA x y z) = c $ ClassA y [x,z]- conv (ClassA x y) = appT (ConT $ c x) (c y)--instance Convert HS.Type TH.Type where- conv (TyCon (Special ListCon)) = ListT- conv (TyCon (Special UnitCon)) = TupleT 0- conv (TyParen x) = c x- conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)- conv (TyVar x) = VarT $ c x- conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x- conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y)- conv (TyList x) = AppT ListT (c x)- conv (TyTuple _ x) = appT (TupleT (length x)) (c x)- conv (TyApp x y) = AppT (c x) (c y)--instance Convert HS.Name TH.Name where- conv = mkName . filter (`notElem` "()") . prettyPrint--instance Convert HS.Match TH.Clause where- conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds)--instance Convert HS.Rhs TH.Body where- conv (UnGuardedRhs x) = NormalB (c x)- conv (GuardedRhss x) = GuardedB (c x)--instance Convert HS.Exp TH.Exp where- conv (Con (Special UnitCon)) = TupE []- conv (Var x) = VarE (c x)- conv (Con x) = ConE (c x)- conv (Lit x) = LitE (c x)- conv (App x y) = AppE (c x) (c y)- conv (Paren x) = c x- conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z)- conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing- conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z)- conv (Lambda _ x y) = LamE (c x) (c y)- conv (Tuple x) = TupE (c x)- conv (If x y z) = CondE (c x) (c y) (c z)- conv (Let x y) = LetE (c x) (c y)- conv (Case x y) = CaseE (c x) (c y)- conv (Do x) = DoE (c x)- conv (EnumFrom x) = ArithSeqE $ FromR (c x)- conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y)- conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y)- conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)- conv (List x) = ListE (c x)- conv (ExpTypeSig _ x y) = SigE (c x) (c y)- conv (RecConstr x y) = RecConE (c x) (c y)- conv (RecUpdate x y) = RecUpdE (c x) (c y) - -- Work around bug 3395, convert to do notation instead- conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x]--instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where- conv = undefined--instance Convert HS.Binds [TH.Dec] where- conv (BDecls x) = c x--instance Convert 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)---#if __GLASGOW_HASKELL__ >= 612-instance Convert TH.TyVarBndr HS.TyVarBind where- conv (PlainTV x) = UnkindedVar $ c x- conv (KindedTV x y) = KindedVar (c x) $ c y--instance Convert TH.Kind HS.Kind where- conv StarK = KindStar- conv (ArrowK x y) = KindFn (c x) $ c y--instance Convert TH.Pred HS.Asst where- conv (ClassP x y) = ClassA (UnQual $ c x) $ c y- conv (TH.EqualP x y) = HS.EqualP (c x) $ c y--instance Convert HS.Asst TH.Pred where- conv (ClassA x y) = ClassP (c x) $ c y- conv (HS.EqualP x y) = TH.EqualP (c x) $ c y--instance Convert HS.TyVarBind TH.TyVarBndr where- conv (UnkindedVar x) = PlainTV $ c x- conv (KindedVar x y) = KindedTV (c x) $ c y--instance Convert HS.Kind TH.Kind where- conv KindStar = StarK- conv (KindFn x y) = ArrowK (c x) $ c y-#endif
− Language/Haskell/TH/All.hs
@@ -1,35 +0,0 @@-{-# OPTIONS_GHC -w #-}--module Language.Haskell.TH.All (- module Language.Haskell.TH.All,- module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,- module Language.Haskell.TH.Helper, module Language.Haskell.TH.FixedPpr,- module Language.Haskell.TH.Data, module Language.Haskell.TH.ExpandSynonym,- ) where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Peephole-import Language.Haskell.TH.Helper-import Language.Haskell.TH.FixedPpr-import Language.Haskell.TH.ExpandSynonym-import Language.Haskell.TH.Data--import Control.Monad------ | The type of ways to derive classes.--- Should not really be in this module!-data Derivation = Derivation {- derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper- derivationName :: String -- ^ The name of the derivation- }----- create a new derivation more abstractly-derivation :: (DataDef -> [Dec]) -> String -> Derivation-derivation f = Derivation (return . f)---derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation-derivationQ = Derivation
− Language/Haskell/TH/Compat.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}---- | Compatibility definitions to paper over differences between 6.10 and 6.12.-module Language.Haskell.TH.Compat where--import Language.Haskell.TH---#if __GLASGOW_HASKELL__ >= 612-fromTyVar :: TyVarBndr -> Name-fromTyVar (PlainTV v) = v-fromTyVar (KindedTV v _) = v-#else-fromTyVar :: Name -> Name-fromTyVar v = v-#endif---dataDefinitionTypeArgs :: Dec -> [Name]-#if __GLASGOW_HASKELL__ >= 612-dataDefinitionTypeArgs (DataD _cx name _ _ args) = args-dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args-#else-dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args-dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args-#endif---#if __GLASGOW_HASKELL__ >= 612-typeToPred :: Type -> Pred-typeToPred (ConT v) = ClassP v []-typeToPred (AppT x y) = ClassP v (t++[y])- where ClassP v t = typeToPred x-#else-typeToPred :: Type -> Type-typeToPred x = x-#endif
− Language/Haskell/TH/Data.hs
@@ -1,119 +0,0 @@---- | The core module of the Data.Derive system. This module contains--- the data types used for communication between the extractors and--- the derivors.-module Language.Haskell.TH.Data where--import Data.Char-import Data.Generics--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Compat----- must be one of DataD or NewtypeD-type DataDef = Dec--type CtorDef = Con---dataName :: DataDef -> String-dataName (DataD _ name _ _ _) = unqualifiedName name-dataName (NewtypeD _ name _ _ _) = unqualifiedName name--qualifiedDataName :: DataDef -> Name-qualifiedDataName (DataD _ name _ _ _) = name-qualifiedDataName (NewtypeD _ name _ _ _) = name--dataArity :: DataDef -> Int-dataArity (DataD _ _ xs _ _) = length xs-dataArity (NewtypeD _ _ xs _ _) = length xs--dataArgs :: DataDef -> [Name]-dataArgs = dataDefinitionTypeArgs---dataCtors :: DataDef -> [CtorDef]-dataCtors (DataD _ _ _ xs _) = xs-dataCtors (NewtypeD _ _ _ x _) = [x]---ctorName :: CtorDef -> String-ctorName (NormalC name _ ) = unqualifiedName name-ctorName (RecC name _ ) = unqualifiedName name-ctorName (InfixC _ name _) = unqualifiedName name-ctorName (ForallC _ _ c ) = ctorName c--qualifiedCtorName :: CtorDef -> Name-qualifiedCtorName (NormalC name _ ) = name-qualifiedCtorName (RecC name _ ) = name-qualifiedCtorName (InfixC _ name _) = name-qualifiedCtorName (ForallC _ _ c ) = qualifiedCtorName c---ctorArity :: CtorDef -> Int-ctorArity (NormalC _ xs ) = length xs-ctorArity (RecC _ xs ) = length xs-ctorArity (InfixC _ _ _ ) = 2-ctorArity (ForallC _ _ c) = ctorArity c---ctorStrictTypes :: CtorDef -> [StrictType]-ctorStrictTypes (NormalC _ xs ) = xs-ctorStrictTypes (RecC _ xs ) = [(b,c) | (a,b,c) <- xs]-ctorStrictTypes (InfixC x _ y ) = [x,y]-ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c---ctorTypes :: CtorDef -> [Type]-ctorTypes = map snd . ctorStrictTypes---ctorFields :: CtorDef -> [String]-ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType]-ctorFields _ = []----- normalisation---- make sure you deal with "GHC.Base.."-dropModule :: String -> String-dropModule xs = case reverse xs of- ('.':xs) -> takeWhile (== '.') xs- xs -> reverse $ takeWhile (/= '.') xs---- i_123432 -> i-dropNumber :: String -> String-dropNumber xs = if all isDigit a then reverse (tail b) else xs- where (a,b) = break (== '_') $ reverse xs---normData :: DataDef -> DataDef-normData = everywhere (mkT normType)- where- normType :: Type -> Type- normType (ConT x) | show x == "[]" = ListT- normType x = x--unqualifiedName :: Name -> String-unqualifiedName = dropModule . show----- convert AppT chains back to a proper list-typeApp :: Type -> (Type, [Type])-typeApp (AppT l r) = (a, b++[r])- where (a,b) = typeApp l-typeApp t = (t, [])----eqConT :: String -> Type -> Bool-eqConT name (ConT x) = name == show x-eqConT _ _ = False--isTupleT :: Type -> Bool-isTupleT (TupleT _) = True-isTupleT (ConT x) = head sx == '(' && last sx == ')' &&- all (== ',') (take (length sx - 2) (tail sx))- where sx = nameBase x-isTupleT _ = False
− Language/Haskell/TH/ExpandSynonym.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | Expand type synonyms in data declarations.--- --- This is needed for some type based derivations.-module Language.Haskell.TH.ExpandSynonym (expandData) where--import Language.Haskell.TH-import Language.Haskell.TH.Compat-import Language.Haskell.TH.Data-import Data.Generics---- | Expand type synonyms in a data declaration-expandData :: DataDef -> Q DataDef-expandData = everywhereM (mkM expandType)--expandType :: Type -> Q Type-expandType t = expandType' t []---- Walk over a type, collecting applied arguments-expandType' :: Type -> [Type] -> Q Type-expandType' (AppT t arg) args = expandType' t (arg:args)-expandType' t@(ConT name) args = do result <- expandSyn name args- case result of- Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args'- _ -> return $ foldl AppT t args-expandType' t args = return $ foldl AppT t args---- Is the name a type synonym and are there enough arguments? if so, apply it-expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type]))-expandSyn name args = recover (return Nothing) $ do- info <- reify name- case info of- TyConI (TySynD _ synArgs t) | length args >= length synArgs- -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym- where (argsInst,argsMore) = splitAt (length synArgs) args- _ -> return Nothing- -- `recover` return Nothing---- Substitute names for types in a type-substitute :: [Name] -> [Type] -> Type -> Type-substitute ns ts = subst (zip ns ts)- where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)- subst s (VarT n)- | Just t' <- lookup n s = t'- subst s (AppT a b) = AppT (subst s a) (subst s b)- subst _ t = t
− Language/Haskell/TH/FixedPpr.hs
@@ -1,407 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}--- TH.Ppr contains a prettyprinter for the--- Template Haskell datatypes--module Language.Haskell.TH.FixedPpr where- -- All of the exports from this module should- -- be "public" functions. The main module TH- -- re-exports them all.--import Text.PrettyPrint.HughesPJ (render)-import Language.Haskell.TH.PprLib-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Data(isTupleT)-import Data.Char ( toLower, isAlpha )--nestDepth :: Int-nestDepth = 4--type Precedence = Int-appPrec, opPrec, noPrec :: Precedence-appPrec = 2 -- Argument of a function application-opPrec = 1 -- Argument of an infix operator-noPrec = 0 -- Others--parensIf :: Bool -> Doc -> Doc-parensIf True d = parens d-parensIf False d = d------------------------------------ Show name with `` and () stripped, so that behaviour is the same--- with fixed and broken syntax-libs-showNameRaw :: Name -> String-showNameRaw = clean . show- where- clean ('(':xs) = init xs- clean ('`':xs) = init xs- clean xs = xs--isPrefixName :: Name -> Bool-isPrefixName = classify . showNameRaw- where- classify xs = case break (=='.') xs of- (_,(_:xs')) -> classify xs'- ((x:xs),[]) -> isAlpha x || x == '_'- _ -> False -- operators ending with .--pprName_ :: Bool -> Name -> Doc-pprName_ True nm | isPrefixName nm = text (showNameRaw nm)- | otherwise = text ("(" ++ showNameRaw nm ++ ")")-pprName_ False nm | isPrefixName nm = text ("`" ++ showNameRaw nm ++ "`")- | otherwise = text (showNameRaw nm)----------------------------------pprint :: Ppr a => a -> String-pprint x = render $ to_HPJ_Doc $ ppr x--class Ppr a where- ppr :: a -> Doc- ppr_list :: [a] -> Doc- ppr_list = vcat . map ppr--instance Ppr a => Ppr [a] where- ppr x = ppr_list x---------------------------------instance Ppr Name where- ppr v = pprName_ True v -- text (show v)---------------------------------instance Ppr Info where-#if __GLASGOW_HASKELL__ >= 700- ppr (ClassI d _) = ppr d-#else- ppr (ClassI d) = ppr d-#endif- ppr (TyConI d) = ppr d- ppr (PrimTyConI name arity is_unlifted) - = text "Primitive"- <+> (if is_unlifted then text "unlifted" else empty)- <+> text "type construtor" <+> quotes (ppr name)- <+> parens (text "arity" <+> int arity)- ppr (ClassOpI v ty cls fix) - = text "Class op from" <+> ppr cls <> colon <+>- vcat [ppr_sig v ty, pprFixity v fix]- ppr (DataConI v ty tc fix) - = text "Constructor from" <+> ppr tc <> colon <+>- vcat [ppr_sig v ty, pprFixity v fix]- ppr (TyVarI v ty)- = text "Type variable" <+> ppr v <+> equals <+> ppr ty- ppr (VarI v ty mb_d fix) - = vcat [ppr_sig v ty, pprFixity v fix, - case mb_d of { Nothing -> empty; Just d -> ppr d }]--ppr_sig v ty = ppr v <+> text "::" <+> ppr ty--pprFixity :: Name -> Fixity -> Doc-pprFixity v f | f == defaultFixity = empty-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v- where ppr_fix InfixR = text "infixr"- ppr_fix InfixL = text "infixl"- ppr_fix InfixN = text "infix"----------------------------------instance Ppr Exp where- ppr = pprExp noPrec--pprExpInfix :: Exp -> Doc-pprExpInfix (VarE v) = pprName_ False v-pprExpInfix (ConE c) = pprName_ False c--pprExp :: Precedence -> Exp -> Doc-pprExp _ (VarE v) = ppr v-pprExp _ (ConE c) - | isTupleT (ConT c) = text (nameBase c)- | c == '[] = text ("[]")- | c == '(:) = text ("(:)")- | otherwise = ppr c-pprExp i (LitE l) = pprLit i l-pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1- <+> pprExp appPrec e2-pprExp i (InfixE (Just e1) op (Just e2))- = parensIf (i >= opPrec) $ pprExp opPrec e1- <+> pprExpInfix op- <+> pprExp opPrec e2-pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1- <+> pprExpInfix op- <+> pprMaybeExp noPrec me2-pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)- <+> text "->" <+> ppr e-pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es--- Nesting in Cond is to avoid potential problems in do statments-pprExp i (CondE guard true false)- = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,- nest 1 $ text "then" <+> ppr true,- nest 1 $ text "else" <+> ppr false]-pprExp i (LetE ds e) = parensIf (i > noPrec) $ text "let" <+> ppr ds- $$ text " in" <+> ppr e-pprExp i (CaseE e ms)- = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"- $$ nest nestDepth (ppr ms)-pprExp i (DoE ss) = parensIf (i > noPrec) $ text "do" <+> ppr ss-pprExp _ (CompE []) = error "Can't happen: pprExp (CompExp [])"--- This will probably break with fixity declarations - would need a ';'-pprExp _ (CompE ss) = text "[" <> ppr s- <+> text "|"- <+> (sep $ punctuate comma $ map ppr ss')- <> text "]"- where s = last ss- ss' = init ss-pprExp _ (ArithSeqE d) = ppr d-pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es-pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t-pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)-pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)--pprFields :: [(Name,Exp)] -> Doc-pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)--pprMaybeExp :: Precedence -> Maybe Exp -> Doc-pprMaybeExp _ Nothing = empty-pprMaybeExp i (Just e) = pprExp i e---------------------------------instance Ppr Stmt where- ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e- ppr (LetS ds) = text "let" <+> ppr ds- ppr (NoBindS e) = ppr e- ppr (ParS sss) = sep $ punctuate (text "|")- $ map (sep . punctuate comma . map ppr) sss---------------------------------instance Ppr Match where- ppr (Match p rhs ds) = ppr p <+> pprBody False rhs- $$ where_clause ds---------------------------------pprBody :: Bool -> Body -> Doc-pprBody eq (GuardedB xs) = nest nestDepth $ vcat $ map do_guard xs- where eqd = if eq then text "=" else text "->"- do_guard (NormalG g, e) = text "|" <+> ppr g <+> eqd <+> ppr e- do_guard (PatG ss, e) = text "|" <+> vcat (map ppr ss)- $$ nest nestDepth (eqd <+> ppr e)-pprBody eq (NormalB e) = (if eq then text "=" else text "->") <+> ppr e---instance Ppr Body where- ppr = pprBody True---------------------------------pprLit :: Precedence -> Lit -> Doc-pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)- (integer x <> char '#')-pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)- (float (fromRational x) <> char '#')-pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)- (double (fromRational x) <> text "##")-pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)-pprLit _ (CharL c) = text (show c)-pprLit _ (StringL s) = text (show s)-pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat--instance Ppr Lit where- ppr = pprLit 10---------------------------------instance Ppr Pat where- ppr = pprPat noPrec--pprPat :: Precedence -> Pat -> Doc-pprPat i (LitP l) = pprLit i l-pprPat _ (VarP v) = ppr v-pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps-pprPat i (ConP s ps) = parensIf (i > noPrec) $ x- <+> sep (map (pprPat appPrec) ps)- where- x | isTupleT (ConT s) = text (nameBase s)- | s == '[] = text "[]"- | s == '(:) = text "(:)"- | otherwise = ppr s--pprPat i (InfixP p1 n p2)- = parensIf (i > noPrec)- $ pprPat opPrec p1 <+> pprName_ False n <+> pprPat opPrec p2-pprPat i (TildeP p) = parensIf (i > noPrec) $ text "~" <> pprPat appPrec p-pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"- <> pprPat appPrec p-pprPat _ WildP = text "_"-pprPat _ (RecP nm fs)- = parens $ ppr nm- <+> braces (sep $ punctuate comma $- map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)-pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps-pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t---------------------------------instance Ppr Dec where- ppr (FunD f cs) = vcat $ map (\c -> ppr f <+> ppr c) cs- ppr (ValD p r ds) = ppr p <+> pprBody True r- $$ where_clause ds- ppr (TySynD t xs rhs) = text "type" <+> ppr t <+> hsep (map ppr xs) - <+> text "=" <+> ppr rhs- ppr (DataD ctxt t xs cs decs)- = text "data"- <+> pprCxt ctxt- <+> ppr t <+> hsep (map ppr xs)- <+> sep (pref $ map ppr cs)- $$ if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)- where pref :: [Doc] -> [Doc]- pref [] = [] -- Can't happen in H98- pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds- ppr (NewtypeD ctxt t xs c decs)- = text "newtype"- <+> pprCxt ctxt- <+> ppr t <+> hsep (map ppr xs)- <+> char '=' <+> ppr c- $$ if null decs- then empty- else nest nestDepth- $ text "deriving"- <+> parens (hsep $ punctuate comma $ map ppr decs)- ppr (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt- <+> ppr c <+> hsep (map ppr xs) <+> ppr fds- $$ where_clause ds- ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i- $$ where_clause (map deQualLhsHead ds)- ppr (SigD f t) = ppr f <+> text "::" <+> ppr t- ppr (ForeignD f) = ppr f- -deQualLhsHead :: Dec -> Dec-deQualLhsHead (FunD n cs) = FunD (deQualName n) cs-deQualLhsHead (ValD p b ds) = ValD (go p) b ds- where- go (VarP n) = VarP (deQualName n)- go (InfixP p1 n p2) = InfixP p1 (deQualName n) p2- go x = x-deQualLhsHead x = x- -deQualName :: Name -> Name-deQualName = mkName . nameBase---------------------------------instance Ppr FunDep where- ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)- ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))---------------------------------instance Ppr Foreign where- ppr (ImportF callconv safety impent as typ)- = text "foreign import"- <+> showtextl callconv- <+> showtextl safety- <+> text (show impent)- <+> ppr as- <+> text "::" <+> ppr typ- ppr (ExportF callconv expent as typ)- = text "foreign export"- <+> showtextl callconv- <+> text (show expent)- <+> ppr as- <+> text "::" <+> ppr typ---------------------------------instance Ppr Clause where- ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs- $$ where_clause ds---------------------------------instance Ppr Con where- ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)- ppr (RecC c vsts)- = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))- ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName_ False c <+> pprStrictType st2- ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)- <+> char '.' <+> pprCxt ctxt <+> ppr con---------------------------------pprVarStrictType :: (Name, Strict, Type) -> Doc--- Slight infelicity: with print non-atomic type with parens-pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)---------------------------------pprStrictType :: (Strict, Type) -> Doc--- Prints with parens if not already atomic-pprStrictType (IsStrict, t) = char '!' <> pprParendType t-pprStrictType (NotStrict, t) = pprParendType t---------------------------------pprParendType :: Type -> Doc-pprParendType (VarT v) = ppr v-pprParendType (ConT c) - | c == ''[] = pprParendType ListT- | c == ''(->) = pprParendType ArrowT- | isTupleT (ConT c) = pprParendType (TupleT (length (nameBase c) - 1))- | otherwise = ppr c-pprParendType (TupleT 0) = text "()"-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))-pprParendType ArrowT = parens (text "->")-pprParendType ListT = text "[]"-pprParendType other = parens (ppr other)--instance Ppr Type where- ppr (ForallT tvars ctxt ty) = - text "forall" <+> hsep (map ppr tvars) <+> text "."- <+> pprCxt ctxt <+> ppr ty- ppr ty = pprTyApp (split ty)--pprTyApp :: (Type, [Type]) -> Doc-pprTyApp (ArrowT, [arg1,arg2]) = sep [ppr arg1 <+> text "->", ppr arg2]-pprTyApp (ListT, [arg]) = brackets (ppr arg)-pprTyApp (TupleT n, args)- | length args == n = parens (sep (punctuate comma (map ppr args)))-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)--split :: Type -> (Type, [Type]) -- Split into function and args-split t = go t []- where go (AppT t1 t2) args = go t1 (t2:args)- go ty args = (ty, args)---------------------------------pprCxt :: Cxt -> Doc-pprCxt [] = empty-pprCxt [t] = ppr t <+> text "=>"-pprCxt ts = parens (hsep $ punctuate comma $ map ppr ts) <+> text "=>"---------------------------------instance Ppr Range where- ppr = brackets . pprRange- where pprRange :: Range -> Doc- pprRange (FromR e) = ppr e <> text ".."- pprRange (FromThenR e1 e2) = ppr e1 <> text ","- <> ppr e2 <> text ".."- pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2- pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","- <> ppr e2 <> text ".."- <> ppr e3---------------------------------where_clause :: [Dec] -> Doc-where_clause [] = empty-where_clause ds = nest nestDepth $ text "where" <+> vcat (map ppr ds)--showtextl :: Show a => a -> Doc-showtextl = text . map toLower . show---#if __GLASGOW_HASKELL__ >= 612--instance Ppr TyVarBndr where- ppr (PlainTV v) = ppr v- ppr (KindedTV v k) = parens $ ppr v <+> text "::" <+> ppr k--instance Ppr Kind where- ppr StarK = text "*"- ppr (ArrowK j k) = ppr j <+> text "->" <+> ppr k--instance Ppr Pred where- ppr (ClassP n ts) = ppr n <+> hsep (map ppr ts)- ppr (EqualP t u ) = ppr t <+> text "~" <+> ppr u--#endif
− Language/Haskell/TH/Helper.hs
@@ -1,248 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}----- | These small short-named functions are intended to make the--- construction of abstranct syntax trees less tedious.-module Language.Haskell.TH.Helper where--import Data.Char--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Data-import Language.Haskell.TH.Compat------ * Special folds for the guessing---applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp-applyWith join xs = foldl AppE join xs-foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs-foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs------ * Syntax elements------- | A simple clause, without where or guards.-sclause :: [Pat] -> Exp -> Clause-sclause pats body = Clause pats (NormalB body) []---- | A default clause with N arguments.-defclause :: Int -> Exp -> Clause-defclause num = sclause (replicate num WildP)---- | A simple Val clause-sval :: Pat -> Exp -> Dec-sval pat body = ValD pat (NormalB body) []---case' :: Exp -> [(Pat, Exp)] -> Exp-case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ]--(->:) :: String -> Exp -> Exp-(->:) nm bdy = LamE [vr nm] bdy---- | We provide 3 standard instance constructors--- instance_default requires C for each free type variable--- instance_none requires no context--- instance_context requires a given context-instance_none :: String -> DataDef -> [Dec] -> Dec-instance_none = instance_context []--instance_default :: String -> DataDef -> [Dec] -> Dec-instance_default n = instance_context [n] n--instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec-instance_context req cls dat defs = InstanceD ctx hed defs- where- vrs = vars 't' (dataArity dat)- hed = l1 cls (lK (dataName dat) vrs)- ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]----- | Build an instance of a class for a data type, using the heuristic--- that the type is itself required on all type arguments.-simple_instance :: String -> DataDef -> [Dec] -> [Dec]-simple_instance cls dat defs = [instance_default cls dat defs]---- | Build an instance of a class for a data type, using the class at the given types-generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec]-generic_instance cls dat ctxTypes defs = [InstanceD ctx hed defs]- where- vrs = vars 't' (dataArity dat)- hed = l1 cls (lK (dataName dat) vrs)- ctx = map (typeToPred . l1 cls) ctxTypes---- | Build a type signature declaration with a string name-sigN :: String -> Type -> Dec-sigN nam ty = SigD (mkName nam) ty---- | Build a fundecl with a string name-funN :: String -> [Clause] -> Dec-funN nam claus = FunD (mkName nam) claus---- * Pattern vs Value abstraction--class Eq nm => NameLike nm where- toName :: nm -> Name-instance NameLike Name where toName = id-instance NameLike String where toName = mkName---- | The class used to overload lifting operations. To reduce code--- duplication, we overload the wrapped constructors (and everything--- else, but that's irrelevant) to work in patterns, expressions, and--- types.-class Valcon a where- -- | Build an application node, with a name for a head and a- -- provided list of arguments.- lK :: NameLike nm => nm -> [a] -> a- -- | Reference a named variable.- vr :: NameLike nm => nm -> a- -- | Lift a TH 'Lit'- raw_lit :: Lit -> a- -- | Tupling- tup :: [a] -> a- -- | Listing- lst :: [a] -> a-instance Valcon Exp where- lK nm ys = let name = toName nm in case (nameBase name, ys) of- ("[]", []) -> ConE name- ("[]", xs) -> lst xs- ((x:_), args) | isUpper x || x == ':' -> foldl AppE (ConE name) args- ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b)- where isOper x = not (isAlpha x || x == '_')- (nm, args) -> foldl AppE (VarE name) args-- vr = VarE . toName- raw_lit = LitE- tup = TupE- lst = ListE-instance Valcon Pat where- lK = ConP . toName- vr = VarP . toName- raw_lit = LitP- tup = TupP- lst = ListP-instance Valcon Type where- lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))- where bNm = nameBase (toName nm)- vr = VarT . toName- raw_lit = error "raw_lit @ Type"-- -- XXX work around bug in GHC < 6.10- -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)- tup [t] = t- tup ts = foldl AppT (TupleT (length ts)) ts-- lst = error "lst @ Type"---- | Build an application node without a given head-app :: Exp -> [Exp] -> Exp-app root args = foldl AppE root args----- | This class is used to overload literal construction based on the--- type of the literal.-class LitC a where- lit :: Valcon p => a -> p-instance LitC Integer where- lit = raw_lit . IntegerL-instance LitC Char where- lit = raw_lit . CharL-instance LitC a => LitC [a] where- lit = lst . map lit-instance (LitC a, LitC b) => LitC (a,b) where- lit (x,y) = tup [lit x, lit y]-instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where- lit (x,y,z) = tup [lit x, lit y, lit z]-instance LitC () where- lit () = tup []----- * Constructor abstraction--dataVars :: DataDef -> [Type]-dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..]---- | Common pattern: list of a familiy of variables-vars :: Valcon a => Char -> Int -> [a]-vars c n = map (vrn c) [1 .. n]---- | Variable based on a letter + number-vrn :: Valcon a => Char -> Int -> a-vrn c n = vr (c : show n)---- | Make a list of variables, one for each argument to a constructor-ctv :: Valcon a => CtorDef -> Char -> [a]-ctv ctor c = vars c (ctorArity ctor)---- | Make a simple pattern to bind a constructor-ctp :: Valcon a => CtorDef -> Char -> a-ctp ctor c = lK (ctorName ctor) (ctv ctor c)---- | Reference the constructor itself-ctc :: Valcon a => CtorDef -> a-ctc = l0 . ctorName----- * Lift a constructor over a fixed number of arguments.--l0 :: (NameLike nm, Valcon a) => nm -> a-l1 :: (NameLike nm, Valcon a) => nm -> a -> a-l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a-l0 s = lK s []-l1 s a = lK s [a]-l2 s a b = lK s [a,b]---- * Pre-lifted versions of common operations-true, false, nil :: Valcon a => a-hNil', hZero' :: Type-true = l0 "True"-false = l0 "False"-nil = l0 "[]"-unit = lit ()-hNil' = l0 "HNil"-hZero' = l0 "HZero"-id' = l0 "id"--cons :: Valcon a => a -> a -> a-cons = l2 ":"--box :: Valcon a => a -> a-return', const' :: Exp -> Exp-hSucc' :: Type -> Type-box x = cons x nil-return' = l1 "return"-const' = l1 "const"-hSucc' = l1 "HSucc"--(==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp-hCons' :: Type -> Type -> Type-(==:) = l2 "=="-(&&:) = l2 "&&"-(++:) = l2 "++"-(>>=:) = l2 ">>="-(>>:) = l2 ">>"-(.:) = l2 "."-(>:) = l2 ">"-ap' = l2 "ap"-hCons' = l2 "HCons"---- | Build a chain of expressions, with an appropriate terminal--- sequence__ does not require a unit at the end (all others are optimised automatically)-(&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp-(&&::) = foldr (&&:) true-(++::) = foldr (++:) nil-(>>::) = foldr (>>:) (return' unit)-(.::) = foldr (.:) id'--sequence__ [] = return' unit-sequence__ xs = foldr1 (>>:) xs----- | K-way liftM-liftmk :: Exp -> [Exp] -> Exp-liftmk hd args = foldl ap' (return' hd) args
− Language/Haskell/TH/Peephole.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where--import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Helper-import Data.Generics-import Data.Maybe-import Data.List-import Debug.Trace--traceMode = False---peephole :: Data a => a -> a-peephole = everywhere (mkT peep) . everywhere (mkT peepPat)------ find a given string, and replace it with a particular expression--- must succeed, so crashes readily (deliberately!)-replaceVars :: [(Name,Exp)] -> Exp -> Exp-replaceVars rep orig = fExp orig- where- fExp x = case x of- VarE y -> fromMaybe x $ lookup y rep- ConE _ -> x- LitE _ -> x- AppE x y -> AppE (fExp x) (fExp y)- CaseE x y -> CaseE (fExp x) (map fMatch y)- TupE xs -> TupE (map fExp xs)- ListE xs -> ListE (map fExp xs)- LamE x y -> LamE x (fPat x y)- _ | null $ map fst rep `intersect` getNames x -> x- _ -> error $ "replaceVar: " ++ show x-- getNames x = everything (++) ([] `mkQ` f) x- where- f :: Name -> [Name]- f x = [x]-- fMatch o@(Match pat (NormalB bod) []) =- Match pat (NormalB $ fPat [pat] bod) []-- -- given these pattern have come into scope- -- continue matching on the rest- fPat :: [Pat] -> Exp -> Exp- fPat pat = replaceVars (filter ((`notElem` used) . fst) rep)- where used = concatMap usedPats pat-- usedPats x = everything (++) ([] `mkQ` f) x- where- f (VarP x) = [x]- f _ = []---replaceVar :: Name -> Exp -> Exp -> Exp-replaceVar name with = replaceVars [(name,with)]------ based on the rewrite combinator in Play-peep :: Exp -> Exp-peep (ListE xs)- | not (null xs) && all (isJust . fromLitChar) xs =- peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs- where- fromLitChar (LitE (CharL x)) = Just x- fromLitChar _ = Nothing--peep (AppE x y)- | x ~= "id" = y--peep (AppE (AppE op x) y)- | Just res <- peepBin op x y = res--peep (InfixE (Just x) op (Just y))- | Just res <- peepBin op x y = res--peep (LamE [] x) = x--peep (LamE [VarP x] (VarE y))- | x == y = l0 "id"--peep (DoE [NoBindS x]) = x--peep x@(ConE _)- | x ~= "[]" = ListE []--peep (AppE (AppE cons x) nil)- | cons ~= ":" && nil ~= "[]" = ListE [x]--peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e])- | ret ~= "return" = peep $ replaceVar p (LitE val) e--peep (LamE [TupP [VarP x, VarP y]] (VarE z))- | x == z = l0 "fst"- | y == z = l0 "snd"--peep (AppE (LamE (VarP x:xs) y) z)- | simple z- = peep $ LamE xs (replaceVar x z y)--peep (AppE (AppE bind (AppE ret x)) y)- | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x--peep (InfixE (Just (AppE ret x)) bind (Just y))- | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x--peep (InfixE (Just (AppE pure x)) ap y)- | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y--peep (InfixE (Just x) fmap (Just (AppE pure y)))- | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)--peep (AppE append (ListE [x]))- | append ~= "++" = peep $ AppE (l0 ":") x--peep (InfixE (Just (ListE [x])) append y)- | append ~= "++" = peep $ InfixE (Just x) (l0 ":") y--peep (InfixE (Just x) cons (Just (ListE xs)))- | cons ~= ":" = peep $ ListE (x:xs)--peep (AppE (AppE (AppE comp f) g) x)- | comp ~= "." = peep $ AppE f (peep $ AppE g x)-peep (AppE (InfixE (Just f) comp (Just g)) x)- | comp ~= "." = peep $ AppE f (peep $ AppE g x)--peep (AppE (AppE (AppE flip f) x) y)- | flip ~= "flip" = peep $ AppE (AppE f y) x--peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)-peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)--peep (AppE f (LamE x (ListE [y])))- | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y)--peep (AppE f (ListE xs))- | f ~= "head" && not (null xs) = head xs- | f ~= "reverse" = ListE $ reverse xs--peep (AppE f (TupE [x,y]))- | f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x--peep (AppE (AppE sq o@(AppE rnf x)) (TupE []))- | sq ~= "seq" && rnf ~= "rnf" = o--peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))- | x == y = z--peep (AppE len (ListE xs))- | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs--peep (TupE [x]) = x--peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]--peep (AppE (CaseE e [Match p (NormalB x) []]) y)- = CaseE e [Match p (NormalB $ peep $ AppE x y) []]---- allow easy flip to tracing mode-peep x | traceMode = trace (show x) x-peep x = x---peepPat :: Pat -> Pat-peepPat (ListP xs)- | all (\x -> case x of LitP (CharL _) -> True- _ -> False) xs =- LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs--peepPat x = x--peepBin :: Exp -> Exp -> Exp -> Maybe Exp-peepBin op x y- | op ~= "." && x ~= "id" = Just y- | op ~= "." && y ~= "id" = Just x- | op ~= "&&" && y ~= "True" = Just x- | op ~= "const" = Just x- | op ~= "map" && x ~= "id" = Just y- | op ~= "++" && x ~= "[]" = Just y- | op ~= "++" && y ~= "[]" = Just x- | op ~= "." && y ~= "id" = Just x- | op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id"- | op ~= "$" = Just $ peep $ AppE x y--peepBin op (LitE (StringL x)) (LitE (StringL y))- | op ~= "++" = Just $ LitE $ StringL (x++y)--peepBin _ _ _ = Nothing---(VarE f) ~= x = show f == x-(ConE f) ~= x = show f == x-(ListE []) ~= "[]" = True-_ ~= _ = False---simple (VarE _) = True-simple (LitE _) = True-simple _ = False
Main.hs view
@@ -1,58 +1,9 @@ module Main(main) where -import Language.Haskell-import Derive.Derivation-import Derive.Generate-import Derive.Test-import Derive.Flags-import Data.List+import Data.Derive.All+import Data.DeriveMain 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- src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src- let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=extension}- real = parse src- mine = parse $ uncomment src- flags <- return $ foldl addFlags flags- [(sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]- let res = performDerive mine $ wantDerive flags real mine- writeDerive file (moduleName mine) flags res---uncomment :: String -> String-uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs-uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs-uncomment (x:xs) = x:uncomment xs-uncomment [] = []----- Taken from HLint, update occasionally-extension =- [OverlappingInstances,UndecidableInstances,IncoherentInstances,RecursiveDo- ,ParallelListComp,MultiParamTypeClasses,NoMonomorphismRestriction,FunctionalDependencies- ,Rank2Types,RankNTypes,PolymorphicComponents,ExistentialQuantification,ScopedTypeVariables- ,ImplicitParams,FlexibleContexts,FlexibleInstances,EmptyDataDecls- ,KindSignatures,BangPatterns,TypeSynonymInstances,TemplateHaskell- ,ForeignFunctionInterface,Generics,NoImplicitPrelude,NamedFieldPuns,PatternGuards- ,GeneralizedNewtypeDeriving,ExtensibleRecords,RestrictedTypeSynonyms,HereDocuments- ,MagicHash,TypeFamilies,StandaloneDeriving,UnicodeSyntax,PatternSignatures,UnliftedFFITypes- ,LiberalTypeSynonyms,TypeOperators,RecordWildCards,RecordPuns,DisambiguateRecordFields- ,OverloadedStrings,GADTs,MonoPatBinds,RelaxedPolyRec,ExtendedDefaultRules,UnboxedTuples- ,DeriveDataTypeable,ConstrainedClassMethods,PackageImports,ImpredicativeTypes- ,NewQualifiedOperators,PostfixOperators,QuasiQuotes,ViewPatterns]+main = deriveMain derivations
+ README.md view
@@ -0,0 +1,168 @@+# Derive [](https://hackage.haskell.org/package/derive) [](https://travis-ci.org/ndmitchell/derive)++**Warning: This package has no official maintainer anymore. Use at your own risk. You may wish to consider the built-in mechanism [`GHC.Generics`](https://hackage.haskell.org/package/base-4.11.1.0/docs/GHC-Generics.html) or libraries such as [`generic-deriving`](https://hackage.haskell.org/package/generic-deriving).**++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 <a href="http://repetae.net/computer/haskell/DrIFT/">DrIFT</a>.++This document proceeds as follows:++* Obtaining and Installing Data.Derive+* Supported Derivations+* Using the Derive Program+* Using Template Haskell Derivations+* Writing a New Derivation++### Acknowledgements++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, Robin Green, Bertram Felgenhauer.+++## Obtaining and Installing Data.Derive++Installation follows the standard pattern of any Haskell library or program, type <tt>cabal update</tt> to update your local hackage database, then <tt>cabal install derive</tt> to install Derive.+++## Supported Derivations++Data.Derive is not limited to any prebuild set of derivations, see later for howto add your own. Out of the box, we provide instances for the following libraries.++<!--+-- GENERATED START+-->++* **[Arbitrary](http://hackage.haskell.org/packages/archive/QuickCheck/latest/doc/html/Test-QuickCheck.html#t%3AArbitrary)** - from the library [QuickCheck](http://hackage.haskell.org/package/QuickCheck)+* **[ArbitraryOld](http://hackage.haskell.org/packages/archive/QuickCheck/1.2.0.0/doc/html/Test-QuickCheck.html#t%3AArbitraryOld)** - from the library [QuickCheck-1.2.0.0](http://hackage.haskell.org/package/QuickCheck-1.2.0.0)+* **[Arities](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Arities.html#t%3AArities)** - from the library [derive](http://hackage.haskell.org/package/derive)+* **[Binary](http://hackage.haskell.org/packages/archive/binary/latest/doc/html/Data-Binary.html#t%3ABinary)** - from the library [binary](http://hackage.haskell.org/package/binary)+* **[BinaryDefer](http://hackage.haskell.org/packages/archive/binarydefer/latest/doc/html/Data-Binary-Defer.html#t%3ABinaryDefer)** - from the library [binarydefer](http://hackage.haskell.org/package/binarydefer)+* **[Bounded](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ABounded)** - from the library [base](http://hackage.haskell.org/package/base)+* **[DataAbstract](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Data.html#t%3ADataAbstract)** - from the library [base](http://hackage.haskell.org/package/base)+* **[Default](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Class-Default.html#t%3ADefault)** - from the library [derive](http://hackage.haskell.org/package/derive)+* **[EnumCyclic](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AEnum)** - from the library [base](http://hackage.haskell.org/package/base)+* **[Fold](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Fold.html)**+* **[From](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-From.html)**+* **[Has](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Has.html)**+* **[Is](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Is.html)**+* **[JSON](http://hackage.haskell.org/packages/archive/json/latest/doc/html/Text-JSON.html#t%3AJSON)** - from the library [json](http://hackage.haskell.org/package/json)+* **[LazySet](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-LazySet.html)**+* **[Lens](http://hackage.haskell.org/packages/archive/data/lens/doc/html/Data-Lens-Common.html#t%3ALens)** - from the library [data-lens](http://hackage.haskell.org/package/data-lens)+* **[Monoid](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid)** - from the library [base](http://hackage.haskell.org/package/base)+* **[NFData](http://hackage.haskell.org/packages/archive/deepseq/latest/doc/html/Control-DeepSeq.html#t%3ANFData)** - from the library [deepseq](http://hackage.haskell.org/package/deepseq)+* **[Ref](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html)**+* **[Serial](http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial)** - from the library [smallcheck](http://hackage.haskell.org/package/smallcheck)+* **[Serialize](http://hackage.haskell.org/packages/archive/cereal/latest/doc/html/Data-Serialize.html#t%3ASerialize)** - from the library [cereal](http://hackage.haskell.org/package/cereal)+* **[Set](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Set.html)**+* **[UniplateDirect](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Direct.html#t%3AUniplateDirect)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)+* **[UniplateTypeable](http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-Uniplate-Typeable.html#t%3AUniplateTypeable)** - from the library [uniplate](http://hackage.haskell.org/package/uniplate)+* **[Update](http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Update.html)**++<!--+-- GENERATED STOP+-->++## Using the Derive program++Let's imagine we've defined a data type:++ data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Eq, Show)++Now we wish to extend this to derive <tt>Binary</tt> and change to defining <tt>Eq</tt> using our library. To do this we simply add to the <tt>deriving</tt> clause.++ data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Show {-! Eq, Binary !-})++Or alternatively write:++ {-!+ deriving instance Eq Color+ deriving instance Binary Color+ !-}++Now running <tt>derive</tt> on the program containing this code will generate appropriate instances. How do you combine these instances back into the code? There are various mechanisms supported.++### Appending to the module++One way is to append the text to the bottom of the module, this can be done by passing the <tt>--append</tt> flag. If this is done, Derive will generate the required instances and place them at the bottom of the file, along with a checksum. Do not modify these instances.++### As a GHC preprocessor++To use Derive as a GHC preprocessor, add the following line at the top of the source file:++ {-# OPTIONS_GHC -F -pgmFderive -optF-F #-}++This instructs GHC to apply a preprocessor (<tt>-F</tt>), and to use the preprocessor <tt>derive -F</tt>.++### Using CPP++One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example:++ {-# LANGUAGE CPP #-}+ {-# OPTIONS_DERIVE --output=file.h #-}++ module ModuleName where+ + #include "file.h"++### Side-by-side Modules++If you had Colour.Type, and wished to place the Binary instance in Colour.Binary, this can be done with:++ {-# OPTIONS_DERIVE --output=Binary.hs --module=Colour.Binary --import #-}++Here you ask for the output to go to a particular file, give a specific module name and import this module. This will only work if the data structure is exported non-abstractly.++## Using Template Haskell Derivations</h2>++One of Derive's advantages over DrIFT is support for <a href="http://www.haskell.org/th/">Template Haskell</a> (abbreviated TH). Derive can be invoked automatically during the compilation process, and transparently supports deriving across module boundaries. The main disadvantage of TH-based deriving is that it is only portable to compilers that support TH; currently that is GHC only.++To use the TH deriving system, with the same example as before:++ {-# LANGUAGE TemplateHaskell #-}+ import Data.DeriveTH+ import Data.Binary+ + data Color = RGB Int Int Int+ | CMYK Int Int Int Int+ deriving (Show)+ + $( derive makeEq ''Color )+ $( derive makeBinary ''Color )++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>.)++## Writing a New Derivation++There are two methods for writing a new derivation, guessing or coding. The guessing method is substantially easier if it will work for you, but is limited to derivations with the following properties:++* Inductive - each derivation must be similar to the previous one. <tt>Binary</tt> does not have this property as a 1 item derivation does not have a tag, but a 2 item derivation does.+* Not inductive on the type - it must be an instance for the constructors, not for the type. <tt>Typeable</tt> violates this property by inducting on the free variables in the data type.+* Not type based - the derivation must not change based on the types of the fields. <tt>Play</tt> and <tt>Functor</tt> both behave differently given differently typed fields.+* Not record based - the derivation must not change on record fields. <tt>Show</tt> outputs the fields, so this is not allowed.++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>.++### Modifying Derive++The standard sequence for testing Derive is:++ $ ghci Main.hs+ :main --generate+ :reload+ :main --test++The `--generate` option will automatically generate DSL's for derivations derived by example. The `--test` option runs all test comparisons and then loads the file with Template Haskell.++### Coding a new derivation++My best suggestion, start with a similar instance, i.e. to make `Eq2` from `Eq` do:++* Copy `Data/Derive/Eq.hs` to `Data/Derive/Eq2.hs`+* Rename some of the bits in `Eq2.hs` from `Eq`+* `ghci` -- load derive+* `:main` --generate -- this adds Eq2.hs to the .cabal/All.hs files etc+* `:reload` -- reload with Eq2.hs++Now fix up `Eq2.hs` appropriately.
derive.cabal view
@@ -1,47 +1,48 @@-Cabal-Version: >= 1.6-Build-Type: Default-Name: derive-Version: 2.4.2+cabal-version: 1.18 build-type: Simple-Copyright: 2006-2011, Neil Mitchell-Maintainer: ndmitchell@gmail.com-Homepage: http://community.haskell.org/~ndm/derive/-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:+name: derive+version: 2.6.5+copyright: Neil Mitchell 2006-2017+author: Neil Mitchell <ndmitchell@gmail.com> and others+maintainer: None+homepage: https://github.com/ndmitchell/derive#readme+bug-reports: https://github.com/ndmitchell/derive/issues+license: BSD3+license-file: LICENSE+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.--Extra-Source-Files:- derive.htm--Executable derive- Main-Is: Main.hs+extra-doc-files:+ README.md+ CHANGES.txt+tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 - Other-Modules:- Derive.Derivation- Derive.Flags- Derive.Generate- Derive.Test- Derive.Utils+source-repository head+ type: git+ location: https://github.com/ndmitchell/derive.git - Build-Depends:- directory, process, bytestring+executable derive+ default-language: Haskell2010+ build-depends: base==4.* , derive+ main-is: Main.hs -Library- Build-Depends:+library+ default-language: Haskell2010+ hs-source-dirs: src+ build-depends: base == 4.*, filepath, syb, template-haskell, containers, pretty,- haskell-src-exts >= 1.9 && < 1.11,- transformers == 0.2.*,+ directory, process, bytestring,+ haskell-src-exts == 1.20.*,+ transformers >= 0.2, uniplate >= 1.5 && < 1.7 - Exposed-Modules:+ exposed-modules:+ Data.DeriveMain Data.DeriveTH Data.DeriveDSL Data.Derive.All@@ -59,7 +60,6 @@ Language.Haskell.TH.Compat Language.Haskell.TH.Data Language.Haskell.TH.ExpandSynonym- Language.Haskell.TH.FixedPpr Language.Haskell.TH.Helper Language.Haskell.TH.Peephole -- GENERATED START@@ -69,31 +69,22 @@ Data.Derive.Binary Data.Derive.BinaryDefer Data.Derive.Bounded- Data.Derive.Data Data.Derive.DataAbstract Data.Derive.Default- Data.Derive.Enum Data.Derive.EnumCyclic- Data.Derive.Eq Data.Derive.Fold- Data.Derive.Foldable Data.Derive.From- Data.Derive.Functor Data.Derive.Has Data.Derive.Is Data.Derive.JSON Data.Derive.LazySet+ Data.Derive.Lens Data.Derive.Monoid Data.Derive.NFData- Data.Derive.Ord- Data.Derive.Read Data.Derive.Ref Data.Derive.Serial Data.Derive.Serialize Data.Derive.Set- Data.Derive.Show- Data.Derive.Traversable- Data.Derive.Typeable Data.Derive.UniplateDirect Data.Derive.UniplateTypeable Data.Derive.Update@@ -102,6 +93,12 @@ -- Mainly internal but some still people use them -- to implement derivations outside Data.Derive.Internal.Derivation- Other-Modules:+ other-modules: Data.Derive.Internal.Instance Data.Derive.Internal.Traversal+ Derive.Main+ Derive.Derivation+ Derive.Flags+ Derive.Generate+ Derive.Test+ Derive.Utils
− derive.htm
@@ -1,249 +0,0 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html>- <head>- <meta http-equiv="Content-Type" content="text/html;charset=utf-8" />- <title>Data.Derive: A User Manual</title>- <style type="text/css">-pre {- border: 2px solid gray;- padding: 1px;- padding-left: 5px;- margin-left: 10px;- background-color: #eee;-}--pre.define {- background-color: #ffb;- border-color: #cc0;-}--body {- font-family: sans-serif;-}--h1, h2, h3 {- font-family: serif;-}--h1 {- color: rgb(23,54,93);- border-bottom: 1px solid rgb(79,129,189);- padding-bottom: 2px;- font-variant: small-caps;- text-align: center;-}--a {- color: rgb(54,95,145);-}--h2 {- color: rgb(54,95,145);-}--h3 {- color: rgb(79,129,189);-}- </style>- </head>- <body>--<h1>Data.Derive: A User Manual</h1>--<p style="text-align:right;margin-bottom:25px;">- by <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a>-</p>--<p>- 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 <a href="http://repetae.net/~john/computer/haskell/DrIFT/">DrIFT</a>.-</p>-<p>- This document proceeds as follows:-</p>-<ol>- <li>Obtaining and Installing Data.Derive</li>- <li>Supported Derivations</li>- <li>Using the Derive Program</li>- <li>Using Template Haskell Derivations</li>- <li>Writing a New Derivation</li>-</ol>--<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, Stefan O'Rear, Robin Green, Bertram Felgenhauer.-</p>---<h2>Obtaining and Installing Data.Derive</h2>--<p>- Data.Derive is available using <a href="http://darcs.net/">darcs</a>:-</p>-<pre>-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>-cabal update-cabal install derive-</pre>---<h2>Supported Derivations</h2>--<p>- 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>--<!----- 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.2.0.0/doc/html/Test-QuickCheck.html#t%3AArbitraryOld'>ArbitraryOld</a></b> - from the library <a href='http://hackage.haskell.org/package/QuickCheck-1.2.0.0'>QuickCheck-1.2.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/base/latest/doc/html/Data-Data.html#t%3ADataAbstract'>DataAbstract</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/json/latest/doc/html/Text-JSON.html#t%3AJSON'>JSON</a></b> - from the library <a href='http://hackage.haskell.org/package/json'>json</a></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/deepseq/latest/doc/html/Control-DeepSeq.html#t%3ANFData'>NFData</a></b> - from the library <a href='http://hackage.haskell.org/package/deepseq'>deepseq</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/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/cereal/latest/doc/html/Data-Serialize.html#t%3ASerialize'>Serialize</a></b> - from the library <a href='http://hackage.haskell.org/package/cereal'>cereal</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/uniplate/latest/doc/html/Data-Generics-Uniplate-Direct.html#t%3AUniplateDirect'>UniplateDirect</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/uniplate/latest/doc/html/Data-Generics-Uniplate-Typeable.html#t%3AUniplateTypeable'>UniplateTypeable</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/derive/latest/doc/html/Data-Derive-Update.html'>Update</a></b></li>-<!----- GENERATED STOP--->--<h2>Using the Derive program</h2>--<p>- Let's imagine we've defined a data type:-</p>-<pre>-data Color = RGB Int Int Int- | CMYK Int Int Int Int- deriving (Eq, Show)-</pre>-<p>- Now we wish to extend this to derive <tt>Binary</tt> and change to defining <tt>Eq</tt> using our library. To do this we simply add to the <tt>deriving</tt> clause.-</p>-<pre>-data Color = RGB Int Int Int- | CMYK Int Int Int Int- deriving (Show {-! Eq, Binary !-})-</pre>-<p>- Or alternatively write:-</p>-<pre>-{-!-deriving instance Eq Color-deriving instance Binary Color-!-}-</pre>-<p>- Now running <tt>derive</tt> on the program containing this code will generate appropriate instances. How do you combine these instances back into the code? There are various mechanisms supported.-</p>--<h3>Appending to the module</h3>--<p>- One way is to append the text to the bottom of the module, this can be done by passing the <tt>--append</tt> flag. If this is done, Derive will generate the required instances and place them at the bottom of the file, along with a checksum. Do not modify these instances.-</p>--<h3>Using CPP</h3>--<p>- One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example:-</p>-<pre>-{-# LANGUAGE CPP #-}-{-# OPTIONS_DERIVE --output=file.h #-}--module ModuleName where--#include "file.h"-</pre>--<h3>Side-by-side Modules</h3>--<p>- If you had Colour.Type, and wished to place the Binary instance in Colour.Binary, this can be done with:-</p>-<pre>-{-# OPTIONS_DERIVE --output=Binary.hs --module=Colour.Binary --import #-}-</pre>-<p>- Here you ask for the output to go to a particular file, give a specific module name and import this module. This will only work if the data structure is exported non-abstractly.-</p>--<h2>Using Template Haskell Derivations</h2>--<p>- One of Derive's advantages over DrIFT is support for <a href="http://www.haskell.org/th/">Template Haskell</a> (abbreviated TH). Derive can be invoked automatically during the compilation process, and transparently supports deriving across module boundaries. The main disadvantage of TH-based deriving is that it is only portable to compilers that support TH; currently that is GHC only.-</p>--<p>- To use the TH deriving system, with the same example as before:-</p>--<pre>-{-# LANGUAGE TemplateHaskell #-}-import Data.DeriveTH-import Data.Binary--data Color = RGB Int Int Int- | CMYK Int Int Int Int- deriving (Show)--$( derive makeEq ''Color )-$( derive makeBinary ''Color )-</pre>--<p>- 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>--<p>- There are two methods for writing a new derivation, guessing or coding. The guessing method is substantially easier if it will work for you, but is limited to derivations with the following properties:-</p>-<ul>- <li>Inductive - each derivation must be similar to the previous one. <tt>Binary</tt> does not have this property as a 1 item derivation does not have a tag, but a 2 item derivation does.</li>- <li>Not inductive on the type - it must be an instance for the constructors, not for the type. <tt>Typeable</tt> violates this property by inducting on the free variables in the data type.</li>- <li>Not type based - the derivation must not change based on the types of the fields. <tt>Play</tt> and <tt>Functor</tt> both behave differently given differently typed fields.</li>- <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, 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>
+ src/Data/Derive/All.hs view
@@ -0,0 +1,35 @@+-- | This module provides convenience re-exports of all the standard+-- Data.Derive derivations.+module Data.Derive.All (Derivation, derivations, module D) where++import Data.Derive.Internal.Derivation++-- GENERATED START+import Data.Derive.Arbitrary as D+import Data.Derive.ArbitraryOld as D+import Data.Derive.Arities as D+import Data.Derive.Binary as D+import Data.Derive.BinaryDefer as D+import Data.Derive.Bounded as D+import Data.Derive.DataAbstract as D+import Data.Derive.Default as D+import Data.Derive.EnumCyclic as D+import Data.Derive.Fold as D+import Data.Derive.From as D+import Data.Derive.Has as D+import Data.Derive.Is as D+import Data.Derive.JSON as D+import Data.Derive.LazySet as D+import Data.Derive.Lens as D+import Data.Derive.Monoid as D+import Data.Derive.NFData as D+import Data.Derive.Ref as D+import Data.Derive.Serial as D+import Data.Derive.Serialize as D+import Data.Derive.Set as D+import Data.Derive.UniplateDirect as D+import Data.Derive.UniplateTypeable as D+import Data.Derive.Update as D+derivations :: [Derivation]+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeDataAbstract,makeDefault,makeEnumCyclic,makeFold,makeFrom,makeHas,makeIs,makeJSON,makeLazySet,makeLens,makeMonoid,makeNFData,makeRef,makeSerial,makeSerialize,makeSet,makeUniplateDirect,makeUniplateTypeable,makeUpdate]+-- GENERATED STOP
+ src/Data/Derive/Arbitrary.hs view
@@ -0,0 +1,106 @@+module Data.Derive.Arbitrary(makeArbitrary) where+{-+import "QuickCheck" Test.QuickCheck++example :: Custom++instance Arbitrary (Sample a) where+ arbitrary = do+ x <- choose (0::Int,length [First{},Second{},Third{}] - 1)+ case x of+ 0 -> do return (First)+ 1 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (Second x1 x2)+ 2 -> do x1 <- arbitrary+ return (Third x1)+ _ -> error "FATAL ERROR: Arbitrary instance, logic bug"++test :: State+instance (CoArbitrary s, Arbitrary s, Arbitrary a) => Arbitrary (State s a) where+ arbitrary = do x1 <- arbitrary+ return (StateT x1)+-}++import Data.Derive.DSL.HSE+import Data.List+import Data.Generics.Uniplate.DataOnly++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArbitrary :: Derivation+makeArbitrary = derivationCustomDSL "Arbitrary" custom $+ List [Instance [] "Arbitrary" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs" (List+ [App "()" (List []),App "Do" (List [App "()" (List []),List [App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "x"])]),App+ "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "choose"])])]),App "Tuple" (List [App "()" (+ List []),App "Boxed" (List []),List [App "ExpTypeSig" (List [App+ "()" (List []),App "Lit" (List [App "()" (List []),App "Int" (List+ [App "()" (List []),Int 0,ShowInt (Int 0)])]),App "TyCon" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "Int"])])])]),App+ "InfixApp" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "length"])])]),App "List" (List [App "()" (List []),MapCtor (App+ "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+ []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String "-"])])]),App "Lit" (List [App "()" (List []),App "Int" (+ List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]])])]),App+ "Qualifier" (List [App "()" (List []),App "Case" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])]),Concat (List [MapCtor (App "Alt" (List [App "()" (List [+ ]),App "PLit" (List [App "()" (List []),App "Signless" (List [App+ "()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,+ ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])+ ,App "Do" (List [App "()" (List []),Concat (List [MapField (App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),Concat (List [+ String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "arbitrary"])])])])),List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "return"])])]),App "Paren" (List [App "()" (List []),Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List+ [App "()" (List []),App "PWildCard" (List [App "()" (List [])]),+ App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "error"])])]),App "Lit" (List [App "()" (List []),App+ "String" (List [App "()" (List []),String+ "FATAL ERROR: Arbitrary instance, logic bug",String+ "FATAL ERROR: Arbitrary instance, logic bug"])])])]),App "Nothing"+ (List [])])]])])])]])]),App "Nothing" (List [])])])]]))]+-- GENERATED STOP++custom = customContext context++-- Fix the context+-- C a b => Arbitrary a, Arbitrary b+-- a -> b => CoArbitrary a, Arbitrary b+context :: FullDataDecl -> Context () -> Context ()+context (_,d) _ = CxTuple () $ nub $ concatMap (f True . snd) $ concatMap ctorDeclFields $ dataDeclCtors d+ where+ f b (TyVar _ x) = [ClassA () (qname $ b ? "Arbitrary" $ "CoArbitrary") [TyVar () x]]+ f b (TyFun _ x y) = f (not b) x ++ f b y+ f b x = concatMap (f b) (children x)+
+ src/Data/Derive/ArbitraryOld.hs view
@@ -0,0 +1,89 @@+module Data.Derive.ArbitraryOld where+{-+import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)++example :: Sample++instance Arbitrary a => Arbitrary (Sample a) where+ arbitrary = do+ x <- choose (0,length [First{},Second{},Third{}]-1)+ case x of+ 0 -> do return (First)+ 1 -> do x1 <- arbitrary+ x2 <- arbitrary+ return (Second x1 x2)+ 2 -> do x1 <- arbitrary+ return (Third x1)++ coarbitrary (First) = ()+ coarbitrary (Second x1 x2) = ()+ coarbitrary (Third x1) = ()++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeArbitraryOld :: Derivation+makeArbitraryOld = derivationDSL "ArbitraryOld" dslArbitraryOld++dslArbitraryOld =+ List [Instance ["Arbitrary"] "Arbitrary" (App "Just" (List [List [+ App "InsDecl" (List [App "()" (List []),App "PatBind" (List [App+ "()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),String "arbitrary"])]),App "UnGuardedRhs"+ (List [App "()" (List []),App "Do" (List [App "()" (List []),List+ [App "Generator" (List [App "()" (List []),App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "x"])]+ ),App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "choose"])])]),App "Tuple" (List [App+ "()" (List []),App "Boxed" (List []),List [App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 0,ShowInt (+ Int 0)])]),App "InfixApp" (List [App "()" (List []),App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "length"])])]),App "List" (List [App "()" (List []+ ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+ "()" (List []),String "-"])])]),App "Lit" (List [App "()" (List []+ ),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]+ ])])]),App "Qualifier" (List [App "()" (List []),App "Case" (List+ [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List+ []),App "PLit" (List [App "()" (List []),App "Signless" (List [App+ "()" (List [])]),App "Int" (List [App "()" (List []),CtorIndex,+ ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()" (List [])+ ,App "Do" (List [App "()" (List []),Concat (List [MapField (App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),Concat (List [+ String "x",ShowInt FieldIndex])])]),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "arbitrary"])])])])),List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "return"])])]),App "Paren" (List [App "()" (List []),Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )]))])])])]])])]),App "Nothing" (List [])]))])])]])]),App+ "Nothing" (List [])])]),App "InsDecl" (List [App "()" (List []),+ App "FunBind" (List [App "()" (List []),MapCtor (App "Match" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "coarbitrary"]),List [App "PParen" (List [App "()" (List []),App+ "PApp" (List [App "()" (List []),App "UnQual" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),CtorName])]),+ MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])+ ]))])])],App "UnGuardedRhs" (List [App "()" (List []),App "Con" (+ List [App "()" (List []),App "Special" (List [App "()" (List []),+ App "UnitCon" (List [App "()" (List [])])])])]),App "Nothing" (+ List [])]))])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Arities.hs view
@@ -0,0 +1,48 @@+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" (App "Just" (List [List [App "InsDecl"+ (List [App "()" (List []),App "FunBind" (List [App "()" (List []),+ List [App "Match" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "arities"]),List [App "PWildCard" (List [App+ "()" (List [])])],App "UnGuardedRhs" (List [App "()" (List []),App+ "List" (List [App "()" (List []),MapCtor (Application (List [App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "const"])])]),App+ "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []+ ),CtorArity,ShowInt CtorArity])]),App "RecConstr" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),List []])]))])]),App "Nothing" (+ List [])])]])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Binary.hs view
@@ -0,0 +1,181 @@+module Data.Derive.Binary where+{-+import "binary" Data.Binary++example :: Sample++instance Binary alpha => Binary (Sample alpha) where+ put x = case x of+ First -> do putTag 0+ Second x1 x2 -> do putTag 1 ; put x1 ; put x2+ Third x1 -> do putTag 2 ; put x1+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ putTag x = when useTag (putWord8 x)++ get = do+ i <- getTag+ case i of+ 0 -> do return (First)+ 1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)+ 2 -> do x1 <- get ; return (Third x1)+ _ -> error "Corrupted binary data for Sample"+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ getTag = if useTag then getWord8 else return 0+++test :: List++instance Binary a => Binary (List a) where+ put x = case x of+ Nil -> putWord8 0+ Cons x1 x2 -> do putWord8 1; put x1; put x2++ get = do+ i <- getWord8+ case i of+ 0 -> return Nil+ 1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)+ _ -> error "Corrupted binary data for List"++test :: Assoced++instance Binary typ => Binary (Assoced typ) where+ put (Assoced x1 x2) = do put x1; put x2+ get = do x1 <- get; x2 <- get; return (Assoced x1 x2)+++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBinary :: Derivation+makeBinary = derivationDSL "Binary" dslBinary++dslBinary =+ List [Instance ["Binary"] "Binary" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),List [App "Match" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "put"]),List [App "PVar" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App "Case" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "x"])])]),MapCtor (App "Alt" (List [App "()" (List+ []),App "PApp" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),+ MapField (App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])+ ]))]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List+ [App "()" (List []),Concat (List [List [App "Qualifier" (List [App+ "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "putTag"])])]),App "Lit"+ (List [App "()" (List []),App "Int" (List [App "()" (List []),+ CtorIndex,ShowInt CtorIndex])])])])],MapField (App "Qualifier" (+ List [App "()" (List []),App "App" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "put"])])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+ ,ShowInt FieldIndex])])])])])]))])])]),App "Nothing" (List [])]))]+ )]),App "Just" (List [App "BDecls" (List [App "()" (List []),List+ [App "PatBind" (List [App "()" (List []),App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "useTag"])]),App "UnGuardedRhs" (List [App "()" (List []),App+ "InfixApp" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "length"])])]),App "List" (List [App "()" (List []),MapCtor (App+ "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+ []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (+ List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App+ "Nothing" (List [])]),App "FunBind" (List [App "()" (List []),List+ [App "Match" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "putTag"]),List [App "PVar" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "x"])])],App+ "UnGuardedRhs" (List [App "()" (List []),Application (List [App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "when"])])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "useTag"])])]),+ App "Paren" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+ List [String "putWord",ShowInt (Int 8)])])])]),App "Var" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "x"])])])])])])]),App+ "Nothing" (List [])])]])]])])])]])]),App "InsDecl" (List [App "()"+ (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "get"])]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (+ List [App "()" (List []),List [App "Generator" (List [App "()" (+ List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "i"])]),App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "getTag"])])])]),App "Qualifier" (List [App+ "()" (List []),App "Case" (List [App "()" (List []),App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "i"])])]),Concat (+ List [MapCtor (App "Alt" (List [App "()" (List []),App "PLit" (+ List [App "()" (List []),App "Signless" (List [App "()" (List [])]+ ),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex]+ )]),App "UnGuardedRhs" (List [App "()" (List []),App "Do" (List [+ App "()" (List []),Concat (List [MapField (App "Generator" (List [+ App "()" (List []),App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),Concat (List [String "x",ShowInt+ FieldIndex])])]),App "Var" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "get"])])])])),List [App "Qualifier" (List [App "()" (List+ []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "return"])])]),App "Paren" (List [App+ "()" (List []),Application (Concat (List [List [App "Con" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),CtorName])])])],MapField (App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+ ,ShowInt FieldIndex])])])]))]))])])])]])])]),App "Nothing" (List [+ ])])),List [App "Alt" (List [App "()" (List []),App "PWildCard" (+ List [App "()" (List [])]),App "UnGuardedRhs" (List [App "()" (+ List []),App "App" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "error"])])]),App "Lit" (List [+ App "()" (List []),App "String" (List [App "()" (List []),Concat (+ List [String "Corrupted binary data for ",DataName]),Concat (List+ [String "Corrupted binary data for ",DataName])])])])]),App+ "Nothing" (List [])])]])])])]])]),App "Just" (List [App "BDecls" (+ List [App "()" (List []),List [App "PatBind" (List [App "()" (List+ []),App "PVar" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "useTag"])]),App "UnGuardedRhs" (List [App+ "()" (List []),App "InfixApp" (List [App "()" (List []),App "App"+ (List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "length"])])]),App "List" (List [App "()" (List []+ ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),List []]))])]),App "QVarOp" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+ "()" (List []),String ">"])])]),App "Lit" (List [App "()" (List []+ ),App "Int" (List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]+ ),App "Nothing" (List [])]),App "PatBind" (List [App "()" (List []+ ),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (+ List []),App "If" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "useTag"])])]),App "Var" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),Concat (List [String "getWord",+ ShowInt (Int 8)])])])]),App "App" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "return"])])]),+ App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+ List []),Int 0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])+ ]])])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/BinaryDefer.hs view
@@ -0,0 +1,83 @@+module Data.Derive.BinaryDefer where+{-+import "binarydefer" Data.Binary.Defer++example :: Sample++instance BinaryDefer a => BinaryDefer (Sample a) where+ bothDefer = defer [\ ~(o@(First)) -> if null [] then unit (First) <<! o else unit First+ ,\ ~(o@(Second x1 x2)) -> if null [const () x1, const () x2] then unit (Second x1 x2) <<! o else unit Second << x1 << x2+ ,\ ~(o@(Third x1)) -> if null [const () x1] then unit (Third x1) <<! o else unit Third << x1+ ]++test :: FailList++instance (BinaryDefer e, BinaryDefer a) => BinaryDefer (FailList e a) where+ bothDefer = defer [\ ~(o@Zoro) -> unit Zoro <<! o+ ,\ ~(Fial x1) -> unit Fial << x1+ ,\ ~(Const x1 x2) -> unit Const << x1 << x2+ ]++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBinaryDefer :: Derivation+makeBinaryDefer = derivationDSL "BinaryDefer" dslBinaryDefer++dslBinaryDefer =+ List [Instance ["BinaryDefer"] "BinaryDefer" (App "Just" (List [+ List [App "InsDecl" (List [App "()" (List []),App "PatBind" (List+ [App "()" (List []),App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "bothDefer"])]),App+ "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"+ (List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "defer"])])]),App "List" (List [App "()" (List []),MapCtor (App+ "Lambda" (List [App "()" (List []),List [App "PIrrPat" (List [App+ "()" (List []),App "PParen" (List [App "()" (List []),App "PAsPat"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "o"]),App "PParen" (List [App "()" (List []),App "PApp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),CtorName])]),MapField (App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),Concat (List [String "x",ShowInt FieldIndex])])]))])])])])])],+ App "If" (List [App "()" (List []),App "App" (List [App "()" (List+ []),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "null"+ ])])]),App "List" (List [App "()" (List []),MapField (Application+ (List [App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "const"])])]),App "Con" (List [App "()" (List []),App "Special" (+ List [App "()" (List []),App "UnitCon" (List [App "()" (List [])])+ ])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])])])]))])]),App "InfixApp" (List+ [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "unit"])])]),App+ "Paren" (List [App "()" (List []),Application (Concat (List [List+ [App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])])])],+ MapField (App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+ List [String "x",ShowInt FieldIndex])])])]))]))])]),App "QVarOp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Symbol" (List [App "()" (List []),String "<<!"])])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "o"])])])]),Fold+ (App "InfixApp" (List [App "()" (List []),Tail,App "QVarOp" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Symbol" (List [App "()" (List []),String "<<"])])]),Head])) (+ Concat (List [Reverse (MapField (App "Var" (List [App "()" (List [+ ]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )),List [App "App" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "unit"])])]),App "Con" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),CtorName])])])])]]))])]))])])]),App+ "Nothing" (List [])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Bounded.hs view
@@ -0,0 +1,56 @@+module Data.Derive.Bounded where+{-+import Prelude++example :: Sample++instance Bounded a => Bounded (Sample a) where+ minBound = head [First, Second (const minBound 1) (const minBound 2), Third (const minBound 1)]+ maxBound = head [Third (const maxBound 1), Second (const maxBound 1) (const maxBound 2), First]++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeBounded :: Derivation+makeBounded = derivationDSL "Bounded" dslBounded++dslBounded =+ List [Instance ["Bounded"] "Bounded" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "minBound"])]),App "UnGuardedRhs" (List+ [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "head"])])]),App+ "List" (List [App "()" (List []),MapCtor (Application (Concat (+ List [List [App "Con" (List [App "()" (List []),App "UnQual" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+ ])])])],MapField (App "Paren" (List [App "()" (List []),+ Application (List [App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "const"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "minBound"])])]),App "Lit" (List [App "()" (List+ []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+ FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "maxBound"])]),App "UnGuardedRhs" (List+ [App "()" (List []),App "App" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "head"])])]),App+ "List" (List [App "()" (List []),Reverse (MapCtor (Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Paren" (List [App "()" (+ List []),Application (List [App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "const"])])]),App "Var" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "maxBound"])])]),App "Lit" (List [App "()" (+ List []),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+ FieldIndex])])])]))]))))])])]),App "Nothing" (List [])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Class/Arities.hs view
@@ -0,0 +1,5 @@++module Data.Derive.Class.Arities where++class Arities a where+ arities :: a -> [Int]
+ src/Data/Derive/Class/Default.hs view
@@ -0,0 +1,5 @@++module Data.Derive.Class.Default where++class Default a where+ def :: a
+ src/Data/Derive/DSL/Apply.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}++module Data.Derive.DSL.Apply(apply, applyEnv, env, Env(..)) where++import Data.Derive.DSL.HSE+import Data.Derive.DSL.DSL+import Data.List+import Data.Generics.Uniplate.DataOnly+++apply :: DSL -> Input -> Out+apply dsl input = fromOutput $ applyEnv dsl env{envInput=input}+++env = Env+ (error "Env.envInput: uninitialised")+ (error "Env.envCtor: uninitialised")+ (error "Env.envField: uninitialised")+ (error "Env.envFold: uninitialised")+++data Env = Env {envInput :: Input+ ,envCtor :: Ctor+ ,envField :: Integer+ ,envFold :: (Output,Output) }++applyEnv :: DSL -> Env -> Output+applyEnv dsl env@(Env input ctor field fold) = f dsl+ where+ f (Instance ctx hd body) =+ OApp "InstDecl"+ [out ()+ ,out (Nothing :: Maybe (Overlap ()))+ ,out (IRule () Nothing context insthead :: InstRule ())+ ,f body]+ where+ context = Just $ CxTuple ()+ [ClassA () (UnQual () $ Ident () c) [TyVar () $ Ident () v]+ | let seen = [x | TyVar () (Ident () x) <- universeBi $ concatMap ctorDeclFields $ dataCtors input]+ , v <- dataDeclVarsStar input `intersect` seen+ , c <- ctx]+ ty = TyParen () $ foldl (TyApp ())+ (TyCon () $ UnQual () $ Ident () $ dataName input)+ (map tyVar $ dataDeclVars input)+ insthead = IHApp () (IHCon () $ UnQual () $ Ident () hd) ty++ f (Application (f -> OList xs)) =+ foldl1 (\a b -> OApp "App" [OApp "()" [],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
+ src/Data/Derive/DSL/DSL.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Derive.DSL.DSL where++import Data.Derive.DSL.HSE+import Data.List+import Data.Data+import Data.Generics.Uniplate.DataOnly++data DSL = App String DSL{-List-}+ | Concat DSL+ | Reverse DSL+ | String String+ | ShowInt DSL+ | Int Integer+ | List [DSL]+ + | MapField DSL+ | MapCtor DSL+ | DataName+ | CtorName+ | CtorIndex+ | CtorArity+ | FieldIndex+ + | Fold DSL DSL+ | Head+ | Tail+ + | Instance [String] String DSL{-[InstDecl]-}+ | Application DSL{-List-}+ deriving (Data,Typeable,Show)++box x = List [x]+nil = List []+append x y = Concat $ List [x,y]+++fromOut :: Output -> DSL+fromOut (OApp x y) = App x (List $ map fromOut y)+fromOut (OList x) = List (map fromOut x)+fromOut (OString x) = String x+fromOut x = error $ show ("fromOut",x)+++{-+_1 s x1 = App s $ List [x1]+_2 s x1 x2 = App s $ List [x1,x2]+_3 s x1 x2 x3 = App s $ List [x1,x2,x3]+_5 s x1 x2 x3 x4 x5 = App s $ List [x1,x2,x3,x4,x5]++o x = fromOut $ out x++dslEq :: DSL+dslEq = box $ Instance ["Eq"] "Eq" $ box $ _1 "InsDecl" $ _1 "FunBind" $ match `append` dull+ where+ match = MapCtor $ _5 "Match" (o $ Symbol "==") (List [vars "x",vars "y"]) (o (Nothing :: Maybe Type)) (_1 "UnGuardedRhs" bod) (o $ BDecls [])+ vars x = _2 "PApp" (_1 "UnQual" $ _1 "Ident" CtorName) (MapField (_1 "PVar" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)))+ bod = Fold (_3 "InfixApp" Head (o $ QVarOp $ UnQual $ Symbol "&&") Tail) $ MapField pair `append` o [Con $ UnQual $ Ident "True"]+ pair = _3 "InfixApp" (var "x") (o $ QVarOp $ UnQual $ Symbol "==") (var "y")+ var x = _1 "Var" $ _1 "UnQual" $ _1 "Ident" $ append (String x) (ShowInt FieldIndex)++ dull = o [Match sl (Symbol "==") [PWildCard,PWildCard] Nothing (UnGuardedRhs $ Con $ UnQual $ Ident "False") (BDecls [])]+-}+++simplifyDSL :: DSL -> DSL+simplifyDSL = transform f+ where+ f (Concat (List xs)) = case g xs of+ [x] -> x+ [] -> List []+ xs -> Concat $ List xs+ f x = x++ g (List x:List y:zs) = g $ List (x++y):zs+ g (List []:xs) = g xs+ g (String "":xs) = g xs+ g (x:xs) = x : g xs+ g [] = []+++prettyTex :: DSL -> String+prettyTex = f id . transform g+ where+ bracket x = "(" ++ x ++ ")"+ + f b (App x (List [])) = x+ f b (App x (List xs)) = b $ unwords $ x : map (f bracket) xs+ f b (App x y) = b $ x ++ " " ++ f bracket y+ f b (Concat x) = b $ "concat " ++ f bracket x+ f b (Reverse x) = b $ "reverse " ++ f bracket x+ f b (String x) = show x+ f b (ShowInt x) = b $ "showInt " ++ f bracket x+ f b (Int x) = show x+ f b (List []) = "nil"+ f b (List x) = b $ "list (" ++ concat (intersperse "," $ map (f id) x) ++ ")"+ f b (MapField x) = b $ "mapField " ++ f bracket x+ f b (MapCtor x) = b $ "mapCtor " ++ f bracket x+ f b DataName = "dataName"+ f b CtorName = "ctorName"+ f b CtorIndex = "ctorIndex"+ f b CtorArity = "ctorArity"+ f b FieldIndex = "fieldIndex"+ f b (Fold x y) = b $ "fold " ++ f bracket x ++ " " ++ f bracket y+ f b Head = "head"+ f b Tail = "tail"+ f b (Instance x y z) = b $ "instance_ " ++ show x ++ " " ++ show y ++ " " ++ f bracket z+ f b (Application x) = b $ "application " ++ f bracket x++ g (App x (List [y])) | x `elem` words "Ident UnGuardedRhs UnQual Lit" = y+ g x = x
+ src/Data/Derive/DSL/Derive.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE PatternGuards #-}++module Data.Derive.DSL.Derive(derive) where++import Control.Arrow+import Data.Derive.DSL.HSE+import Data.Derive.DSL.DSL+import Data.Derive.DSL.Apply+import Data.List+import Data.Char+import Data.Maybe+++data Guess = Guess DSL+ | GuessFld Int DSL+ | GuessCtr Int Bool DSL -- 0 based index, does it mention CtorName+ deriving Show+++ctrNames = map ctorName $ dataCtors sample+++derive :: Out -> [DSL]+derive x = [simplifyDSL y | Guess y <- guess $ toOutput x]+++guess :: Output -> [Guess]+guess (OApp "InstDecl" [_,OApp "Nothing" [],rule,decls])+ | OApp "IRule" [_, OApp "Nothing" [], ctx, ihead] <- unparen rule+ , (name, types) <- unInstHead ihead+ , OApp "UnQual" [_, OApp "Ident" [_, OString name]] <- name+ , [OApp "TyParen" [_,OApp "TyApp"+ [_,OApp "TyCon" [_,OApp "UnQual" [_,OApp "Ident" [_,OString nam]]]+ ,OApp "TyVar" [_,OApp "Ident" [_,OString var]]]]] <- types+ , nam == dataName sample+ = [Guess $ Instance (unContext ctx) name y | Guess y <- guess decls]+ where+ unContext (OApp "Just" [x])+ | OApp "CxSingle" [_,x] <- x = unClass x+ | OApp "CxTuple" [_,OList xs] <- x = concatMap unClass xs+ unContext x = []++ unClass (OApp "ClassA" [_,OApp "UnQual" [_,OApp "Ident" [_,OString x]],_]) = [x]+ unClass _ = []++ unInstHead (OApp "IHCon" [_, name]) = (name, [])+ unInstHead (OApp "IHInfix" [_, ty, name]) = (name, [ty])+ unInstHead (OApp "IHParen" [_, x]) = unInstHead x+ unInstHead (OApp "IHApp" [_, hd, ty]) = second (++[ty]) $ unInstHead hd++ unparen (OApp p [_, x]) | "Paren" `isInfixOf` p = unparen x+ unparen x = x++guess (OList xs) = guessList xs+guess o@(OApp op xs) = gssFold o ++ gssApp o ++ map (lift (App op)) (guessList xs)+ +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 [pre,x,m,y]) = f True (x : follow True y) ++ f False (y : follow False x)+ where+ follow dir (OApp op2 [pre2,a,m2,b]) | op == op2 && pre == pre2 && m == m2 = a2 : follow dir b2+ where (a2,b2) = if dir then (a,b) else (b,a)+ follow dir x = [x]++ f dir xs | length xs <= 2 = []+ f dir xs | pre:_ <- [d | Guess d <- guess pre] = map (lift $ g pre) $ guess $ OList xs+ where g pre = Fold (App op $ List [pre,h,fromOut m,t])+ (h,t) = if dir then (Head,Tail) else (Tail,Head)++gssFold _ = []+++gssApp (OApp "App" [_,OApp "App" [_,x,y],z]) = map (lift Application) $ guess $ OList $ fromApp x ++ [y,z]+ where fromApp (OApp "App" [_,x,y]) = fromApp x ++ [y]+ 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
+ src/Data/Derive/DSL/HSE.hs view
@@ -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 Data.Data+import Data.Generics.Uniplate.DataOnly+import Data.Maybe+import Data.List+import Data.Function+import Control.Monad.Trans.State+++---------------------------------------------------------------------+-- EXAMPLES++{-+-- data List a = Nil | Cons a (List a)+list :: Input+list = Input "List" 1 [Ctor "Nil" 0 0, Ctor "Cons" 1 2]+-}+++-- data Sample a = First | Second a a | Third a+sample :: Input+sample = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ name "Sample") (tyVarBind "a")) ctrs []+ where+ ctrs = [ctr "First" 0, ctr "Second" 2, ctr "Third" 1]+ ctr s i = QualConDecl () Nothing Nothing $ ConDecl () (name s) $ replicate i $ tyVar "a"+++---------------------------------------------------------------------+-- UTILITIES++outEq :: Out -> Out -> Bool+outEq = (==) `on` transformBi (const sl)++---------------------------------------------------------------------++showOut x = unlines $ map prettyPrint x+++type Input = DataDecl+type Ctor = CtorDecl++dataName = dataDeclName+dataVars = length . dataDeclVars+dataCtors = dataDeclCtors+ctorName = ctorDeclName+ctorArity = fromIntegral . ctorDeclArity++ctorIndex :: Input -> Ctor -> Integer+ctorIndex dat ctor = fromIntegral $ fromMaybe (error "fromJust: ctorIndex") $ findIndex (== ctor) $ dataCtors dat+++toInput :: DataDecl -> Input+toInput x = x+++type Out = [Decl ()]++++data Output = OString String+ | OInt Integer+ | OApp String [Output]+ | OList [Output]+ | OIgnore+ | OCustom String+ deriving (Eq,Show,Data,Typeable)+++toOutput :: Data a => a -> Output+toOutput x+ | t == typeOf "" = OString $ coerce x+ | c == "[]" = OList $ fList x+ | t == typeOf sl = OIgnore+ | t == typeOf (1 :: Integer) = OInt $ coerce x+ | otherwise = OApp (showConstr $ toConstr x) (filter (/= OIgnore) $ gmapQ toOutput x)+ where+ t = typeOf x+ c = show $ fst $ splitTyConApp t++ fList :: Data a => a -> [Output]+ fList = gmapQl (++) [] $ \x -> if typeOf x == t then fList x else [toOutput x]++fromOutput :: Data a => Output -> a+fromOutput (OList xs) = res+ where res = f xs+ f [] = fromConstr $ readCon dat "[]"+ f (x:xs) = fromConstrB (g x (f xs `asTypeOf` res)) $ readCon dat "(:)"+ dat = dataTypeOf res++ g :: (Data a, Data b) => Output -> a -> b+ g x xs = r2 where r2 = if typeOf r2 == typeOf xs then coerce xs else fromOutput x++fromOutput (OApp str args) = res+ where dat = dataTypeOf res+ res = evalState (fromConstrM f $ readCon dat str) args+ f :: Data a => State [Output] a+ f = res where res = if typeOf (fromState res) == typeOf sl then return $ coerce sl else+ do l <- get+ case l of+ x:xs -> do put xs; return $ fromOutput x+ [] -> error "fromOutput: null"++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
+ src/Data/Derive/DSL/SYB.hs view
@@ -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.Trans.State+import Control.Monad+import Data.Generics+import Data.Maybe+++dslSYB :: DSL -> Maybe Out+dslSYB = syb+++syb :: Data a => DSL -> Maybe a+syb = dsimple & dlistAny & dapp -- & (\x -> error $ "Failed to generate for SYB, " ++ show x)++lift :: (Data a, Data b) => (DSL -> Maybe b) -> (DSL -> Maybe a)+lift f = maybe Nothing id . cast . f++(&) 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,l) <- get+ case l of+ x:xs ->+ case syb x of+ Nothing -> do put (False,xs) ; return undefined+ Just y -> do put (b,xs) ; return y+ [] ->+ error "dapp: null"+++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+ let ctx = ClassA () (UnQual () $ Ident () "Data") [TyVar () $ Ident () "d_type"]+ let rule = IRule () Nothing (Just (CxSingle () ctx))+ (IHApp () (IHCon () (UnQual () $ Ident () name)) (TyVar () $ Ident () "d_type"))+ return $ InstDecl () Nothing rule bod+++dstring :: DSL -> Maybe String+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 () (PVar () $ Ident () "d_ctor")+ (H.App () (v "d_dataCtors") (Paren () $ ExpTypeSig () (v "undefined") (TyVar () $ Ident () "d_type")))]+++dsingle :: DSL -> Maybe (Exp ())+dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorArity,ShowInt CtorArity])])) = Just $ Paren () $ H.App () (v "d_ctorArity") (v "d_ctor")+dsingle (App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt CtorIndex])])) = Just $ Paren () $ H.App () (v "d_ctorIndex") (v "d_ctor")+dsingle (App "RecConstr" (List [_, App "UnQual" (List [_, App "Ident" (List [_, CtorName])]),List []])) = Just $ Paren () $+ ExpTypeSig () (H.App () (v "d_ctorValue") (v "d_ctor")) (TyVar () $ Ident () "d_type")+dsingle _ = Nothing+++dapplication :: DSL -> Maybe (Exp ())+dapplication x = do+ Application (List xs) <- return x+ syb $ f xs+ where+ f (x:y:z) = f (App "App" (List [App "()" $ List [],x,y]) : z)+ f [x] = x+++v = Var () . UnQual () . Ident ()
+ src/Data/Derive/DataAbstract.hs view
@@ -0,0 +1,79 @@+{-|+ For deriving Data on abstract data types.+-}+module Data.Derive.DataAbstract(makeDataAbstract) where+{-+import Data.Data(Data(..))++example :: Custom++instance Typeable a => Data (Sample a) where+ gfoldl k r x = r x+ gunfold = error "Data.gunfold not implemented on abstract data type: Sample"+ toConstr = error "Data.gunfold not implemented on abstract data type: Sample"+ dataTypeOf = error "Data.gunfold not implemented on abstract data type: Sample"++-}++import Data.Derive.DSL.HSE++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeDataAbstract :: Derivation+makeDataAbstract = derivationCustomDSL "DataAbstract" custom $+ List [Instance ["Typeable"] "Data" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),List [App "Match" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "gfoldl"]),List [App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "k"])]),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "r"])]),App "PVar" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "x"])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App "()"+ (List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "r"])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])])])]),App "Nothing" (List [])])]])]),App "InsDecl" (List [+ App "()" (List []),App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "gunfold"])]),App "UnGuardedRhs" (List [App "()" (List+ []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "error"])])]),App "Lit" (List [App "()"+ (List []),App "String" (List [App "()" (List []),Concat (List [+ String "Data.gunfold not implemented on abstract data type: ",+ DataName]),Concat (List [String+ "Data.gunfold not implemented on abstract data type: ",DataName])]+ )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"+ (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "toConstr"])]),App "UnGuardedRhs" (List [App "()" (List []),App+ "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "error"])])]),App "Lit" (List [App "()" (+ List []),App "String" (List [App "()" (List []),Concat (List [+ String "Data.gunfold not implemented on abstract data type: ",+ DataName]),Concat (List [String+ "Data.gunfold not implemented on abstract data type: ",DataName])]+ )])])]),App "Nothing" (List [])])]),App "InsDecl" (List [App "()"+ (List []),App "PatBind" (List [App "()" (List []),App "PVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "dataTypeOf"])]),App "UnGuardedRhs" (List [App "()" (List []),App+ "App" (List [App "()" (List []),App "Var" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "error"])])]),App "Lit" (List [App "()" (+ List []),App "String" (List [App "()" (List []),Concat (List [+ String "Data.gunfold not implemented on abstract data type: ",+ DataName]),Concat (List [String+ "Data.gunfold not implemented on abstract data type: ",DataName])]+ )])])]),App "Nothing" (List [])])])]]))]+-- GENERATED STOP++custom = customContext context++context :: FullDataDecl -> Context () -> Context ()+context d _ = CxTuple () [ClassA () (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]
+ src/Data/Derive/Default.hs view
@@ -0,0 +1,38 @@+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" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "def"])]),App "UnGuardedRhs" (List [App+ "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "head"])])]),App "List" (+ List [App "()" (List []),MapCtor (Application (Concat (List [List+ [App "Con" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])])])],+ MapField (App "Paren" (List [App "()" (List []),Application (List+ [App "Var" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),String "const"])])+ ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "def"]+ )])]),App "Lit" (List [App "()" (List []),App "Int" (List [App+ "()" (List []),FieldIndex,ShowInt FieldIndex])])])]))])))])])]),+ App "Nothing" (List [])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/EnumCyclic.hs view
@@ -0,0 +1,152 @@+module Data.Derive.EnumCyclic where+{-+import Prelude(Enum)++example :: Sample++instance Enum (Sample a) where+ toEnum 0 = First{}+ toEnum 1 = Second{}+ toEnum 2 = Third{}+ toEnum n = error $ "toEnum " ++ show n ++ ", not defined for Sample"++ fromEnum (First{}) = 0+ fromEnum (Second{}) = 1+ fromEnum (Third{}) = 2+++ succ a = if b == length [First{},Second{},Third{}] then toEnum 0 else toEnum (b+1)+ where b = fromEnum a++ pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)+ where b = fromEnum a++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeEnumCyclic :: Derivation+makeEnumCyclic = derivationDSL "EnumCyclic" dslEnumCyclic++dslEnumCyclic =+ List [Instance [] "Enum" (App "Just" (List [List [App "InsDecl" (+ List [App "()" (List []),App "FunBind" (List [App "()" (List []),+ Concat (List [MapCtor (App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "toEnum"]),List [App+ "PLit" (List [App "()" (List []),App "Signless" (List [App "()" (+ List [])]),App "Int" (List [App "()" (List []),CtorIndex,ShowInt+ CtorIndex])])],App "UnGuardedRhs" (List [App "()" (List []),App+ "RecConstr" (List [App "()" (List []),App "UnQual" (List [App "()"+ (List []),App "Ident" (List [App "()" (List []),CtorName])]),List+ []])]),App "Nothing" (List [])])),List [App "Match" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "toEnum"]),List [App "PVar" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "n"])])],App "UnGuardedRhs" (List+ [App "()" (List []),App "InfixApp" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "error"])])]),App+ "QVarOp" (List [App "()" (List []),App "UnQual" (List [App "()" (+ List []),App "Symbol" (List [App "()" (List []),String "$"])])]),+ Fold (App "InfixApp" (List [App "()" (List []),Head,App "QVarOp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Symbol" (List [App "()" (List []),String "++"])])]),Tail])) (+ List [App "Lit" (List [App "()" (List []),App "String" (List [App+ "()" (List []),String "toEnum ",String "toEnum "])]),App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "show"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "n"])])])]),App "Lit" (List [App "()" (List []),+ App "String" (List [App "()" (List []),Concat (List [String+ ", not defined for ",DataName]),Concat (List [String+ ", not defined for ",DataName])])])])])]),App "Nothing" (List [])]+ )]])])]),App "InsDecl" (List [App "()" (List []),App "FunBind" (+ List [App "()" (List []),MapCtor (App "Match" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "fromEnum"])+ ,List [App "PParen" (List [App "()" (List []),App "PRec" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),CtorName])]),List []])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "Lit" (List [App "()"+ (List []),App "Int" (List [App "()" (List []),CtorIndex,ShowInt+ CtorIndex])])]),App "Nothing" (List [])]))])]),App "InsDecl" (List+ [App "()" (List []),App "FunBind" (List [App "()" (List []),List [+ App "Match" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "succ"]),List [App "PVar" (List [App "()" (List [+ ]),App "Ident" (List [App "()" (List []),String "a"])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "If" (List [App "()"+ (List []),App "InfixApp" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "b"])])]),App "QVarOp" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Symbol" (List [App "()" (List []),String "=="])])]),App "App"+ (List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "length"])])]),App "List" (List [App "()" (List []+ ),MapCtor (App "RecConstr" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),List []]))])])]),App "App" (List [App "()" (List []),+ App "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "toEnum"])])+ ]),App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+ List []),Int 0,ShowInt (Int 0)])])]),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "toEnum"])])]),App "Paren" (List [App "()" (List []),App+ "InfixApp" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "b"])])]),App "QVarOp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+ List [App "()" (List []),String "+"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App+ "()" (List []),List [App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),+ App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "fromEnum"])])]),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "a"])])])])]),App "Nothing" (List+ [])])]])])])]])]),App "InsDecl" (List [App "()" (List []),App+ "FunBind" (List [App "()" (List []),List [App "Match" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "pred"+ ]),List [App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "a"])])],App "UnGuardedRhs" (List [App+ "()" (List []),App "If" (List [App "()" (List []),App "InfixApp" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "b"])])]),App "QVarOp" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Symbol" (List [App+ "()" (List []),String "=="])])]),App "Lit" (List [App "()" (List [+ ]),App "Int" (List [App "()" (List []),Int 0,ShowInt (Int 0)])])])+ ,App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "toEnum"])])]),App "Paren" (List [App+ "()" (List []),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "length"])])]),App "List"+ (List [App "()" (List []),MapCtor (App "RecConstr" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),List []]))])])])]),App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "toEnum"])])]),App "Paren" (List [App "()" (List [+ ]),App "InfixApp" (List [App "()" (List []),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "b"])])]),App "QVarOp" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Symbol"+ (List [App "()" (List []),String "-"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])])])])]),App "Just" (List [App "BDecls" (List [App+ "()" (List []),List [App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "b"])]),App "UnGuardedRhs" (List [App "()" (List []),+ App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "fromEnum"])])]),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "a"])])])])]),App "Nothing" (List+ [])])]])])])]])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Fold.hs view
@@ -0,0 +1,67 @@+-- Contributed by Tim Newsham <newsham -AT- lava -DOT- net>++{-|+ A pseudo derivation. Derive a (non-recursive) fold function for + the type which takes one function per alternative constructor. Each+ function takes the same arguments as the constructor and returns+ a value. When applied to a value the fold function applies the+ function for the matching constructor to the constructor fields.+ This provides a first-class alternative to pattern matching to+ deconstruct the data type.+-}+module Data.Derive.Fold(makeFold) where+{-+test :: Computer++foldComputer :: (Double -> Int -> a) -> (Int -> a) -> Computer -> a+foldComputer f _ (Laptop x1 x2) = f x1 x2+foldComputer _ f (Desktop x1) = f x1++test :: Assoced++foldAssoced :: (typ -> String -> a) -> Assoced typ -> a+foldAssoced f (Assoced x1 x2) = f x1 x2++test :: Either++foldEither :: (a -> c) -> (b -> c) -> Either a b -> c+foldEither f _ (Left x1) = f x1+foldEither _ f (Right x1) = f x1++test :: Bool++foldBool :: a -> a -> Bool -> a+foldBool f _ False = f+foldBool _ f True = f++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+import Data.Generics.Uniplate.DataOnly+++makeFold :: Derivation+makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d+++mkFold :: DataDecl -> [Decl ()]+mkFold d | isIdent $ dataDeclName d = [TypeSig () [name n] (foldType d), FunBind () $ zipWith f [0..] $ dataDeclCtors d]+ | otherwise = []+ where+ n = "fold" ++ title (dataDeclName d)+ f i c = Match () (name n) pat (UnGuardedRhs () bod) Nothing+ where pat = replicate i (PWildCard ()) ++ [pVar "f"] ++ replicate (length (dataDeclCtors d) - i - 1) (PWildCard ()) +++ [PParen () $ PApp () (qname $ ctorDeclName c) (map pVar vars)]+ bod = apps (var "f") (map var vars)+ vars = ['x' : show i | i <- [1..length (ctorDeclFields c)]]+++foldType :: DataDecl -> Type ()+foldType d = tyFun $ map f (dataDeclCtors d) ++ [dt, v]+ where+ dt = dataDeclType d+ v = head $ map (tyVar . return) ['a'..] \\ universe dt+ f c = TyParen () $ tyFun $ map snd (ctorDeclFields c) ++ [v]+
+ src/Data/Derive/From.hs view
@@ -0,0 +1,65 @@+{-|+ A pseudo derivation. For each constructor in the data type,+ deriving @From@ generates @from@/CtorName/ which extracts the+ components if given the appropriate constructor, and crashes+ otherwise. Unlike the DrIFT @\"From\"@ derivation, our version+ works for all constructors - zero-arity constructors always return+ @()@, arity-one constructors return the contained value, and all+ others return a tuple with all the components.+-}++module Data.Derive.From(makeFrom) where++{-++test :: Sample++fromFirst :: Sample a -> ()+fromFirst First = ()+fromFirst _ = error "fromFirst failed, not a First"++fromSecond :: Sample a -> (a, a)+fromSecond (Second x1 x2) = (x1,x2)+fromSecond _ = error "fromSecond failed, not a Second"++fromThird :: Sample a -> a+fromThird (Third x1) = x1+fromThird _ = error "fromThird failed, not a Third"++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeFrom :: Derivation+makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d+++makeFromCtor :: DataDecl -> CtorDecl -> [Decl ()]+makeFromCtor d c | isIdent n = [TypeSig () [name from] typ, FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]+ | otherwise = []+ where+ n = ctorDeclName c+ from = "from" ++ n++ typ = TyFun () (dataDeclType d)+ (tyTuple $ map snd $ ctorDeclFields c)++ match = Match () (name from) [pat] (UnGuardedRhs () rhs) Nothing+ pat = (length vars == 0 ? id $ PParen ()) $ PApp () (qname n) (map pVar vars)+ vars = take (length $ ctorDeclFields c) $ map ((:) 'x' . show) [1..]+ rhs = valTuple $ map var vars++ defMatch = Match () (name from) [PWildCard ()] (UnGuardedRhs () err) Nothing+ err = App () (var "error") $ Lit () $ let s = from ++ " failed, not a " ++ n in String () s (show s)+++tyTuple [] = TyCon () $ Special () $ UnitCon ()+tyTuple [x] = x+tyTuple xs = TyTuple () Boxed xs+++valTuple [] = Con () $ Special () $ UnitCon ()+valTuple [x] = x+valTuple xs = Tuple () Boxed xs
+ src/Data/Derive/Has.hs view
@@ -0,0 +1,40 @@+{-|+ Has is a pseudo derivation. For each field of any constructor of+ the data type, Has generates @has@/FieldName/ which returns 'True'+ if given the the given field is a member of the constructor of the+ passed object, and 'False' otherwise.+-}+module Data.Derive.Has(makeHas) where++{-+test :: Computer++hasSpeed :: Computer -> Bool+hasSpeed _ = True++hasWeight :: Computer -> Bool+hasWeight Laptop{} = True+hasWeight _ = False++test :: Sample+-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+++makeHas :: Derivation+makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d+++makeHasField :: DataDecl -> String -> [Decl ()]+makeHasField d field = if isIdent field then [TypeSig () [name has] typ, binds has ms] else []+ where+ has = "has" ++ title field+ typ = TyFun () (dataDeclType d) (tyCon "Bool")+ (yes,no) = partition (elem field . map fst . ctorDeclFields) $ dataDeclCtors d+ match pat val = ([pat], con val)++ ms | null no = [match (PWildCard ()) "True"]+ | otherwise = [match (PRec () (qname $ ctorDeclName c) []) "True" | c <- yes] ++ [match (PWildCard ()) "False"]
+ src/Data/Derive/Instance/Arities.hs view
@@ -0,0 +1,14 @@+-- GENERATED START+{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}++module Data.Derive.Instance.Arities where++import Data.Derive.Class.Arities+import Data.Derive.Internal.Instance++instance Data d_type => Arities d_type where+ arities _+ = [const (d_ctorArity d_ctor) (d_ctorValue d_ctor :: d_type) |+ d_ctor <- d_dataCtors (undefined :: d_type)]++-- GENERATED STOP
+ src/Data/Derive/Internal/Derivation.hs view
@@ -0,0 +1,46 @@++module Data.Derive.Internal.Derivation(+ Derivation(..),+ derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,+ customSplice, customContext+ ) where++import Data.DeriveDSL+import Data.Derive.DSL.HSE+import Data.Generics.Uniplate.DataOnly+++data Derivation = Derivation+ {derivationName :: String+ ,derivationOp :: Type () -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]+ }+++derivationParams :: String -> ([Type ()] -> (String -> Decl ()) -> FullDataDecl -> Either String [Decl ()]) -> Derivation+derivationParams name op = Derivation name $ \ty grab decs -> op (snd $ fromTyApps $ fromTyParen ty) grab decs+++derivationCustom :: String -> (FullDataDecl -> Either String [Decl ()]) -> Derivation+derivationCustom name op = derivationParams name $ \ty grab decs -> op decs+++derivationDSL :: String -> DSL -> Derivation+derivationDSL name dsl = derivationCustomDSL name (const id) dsl+++derivationCustomDSL :: String -> (FullDataDecl -> [Decl ()] -> [Decl ()]) -> DSL -> Derivation+derivationCustomDSL name custom dsl = derivationCustom name $+ \d -> case applyDSL dsl $ snd d of+ Left x -> Left x+ Right x -> Right $ simplify $ custom d x+++customSplice :: (FullDataDecl -> Exp () -> Exp ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])+customSplice custom d = transformBi f+ where+ f (SpliceExp () (ParenSplice () x)) = custom d x+ f x = x+++customContext :: (FullDataDecl -> Context () -> Context ()) -> (FullDataDecl -> [Decl ()] -> [Decl ()])+customContext custom ds = transformBi (custom ds)
+ src/Data/Derive/Internal/Instance.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ExistentialQuantification #-}++module Data.Derive.Internal.Instance(+ Data, d_ctorArity, d_ctorValue, d_dataCtors+ ) where++import Data.Data+import Control.Monad+import Control.Monad.Trans.State+++data Ctor = Ctor+ {ctorType :: Box+ ,ctorRep :: Constr}+++data Box = forall a . Data a => Box a+++d_ctorArity :: Ctor -> Int+d_ctorArity Ctor{ctorType=Box t, ctorRep=rep} = flip execState 0 $+ liftM (`asTypeOf` t) $+ fromConstrM (modify (+1) >> return undefined) rep+++d_ctorValue :: Data a => Ctor -> a+d_ctorValue = error "TODO: d_ctorValue"+++d_dataCtors :: Data a => a -> [Ctor]+d_dataCtors x+ | not $ isAlgType t = error "d_dataCtors only works on algebraic data types"+ | otherwise = map (Ctor $ Box x) $ dataTypeConstrs t+ where t = dataTypeOf x
+ src/Data/Derive/Internal/Traversal.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE CPP #-}+{-+ This module is not written/maintained by the usual Data.Derive author.++ MAINTAINER: Twan van Laarhoven+ EMAIL: "twanvl" ++ "@" ++ "gmail" ++ "." ++ "com"++ Please send all patches to this module to Neil (ndmitchell -at- gmail),+ and CC Twan.+-}++-- NOTE: Cannot be guessed as it relies on type information++-- | Derives 'Functor' and similair classes, as discussed on the Haskell-prime mailing list:+-- <http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html>.+module Data.Derive.Internal.Traversal(+ TraveralType(..), defaultTraversalType,+ traversalDerivation1,+ traversalInstance, traversalInstance1,+ deriveTraversal+ ) where++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.List+import qualified Data.Set as S+import Control.Monad.Trans.Writer+import Control.Applicative+import Data.Generics.Uniplate.DataOnly+import Data.Maybe+import Prelude++---------------------------------------------------------------------------------+-- Information datatype, public interface++-- | An expression representing a traversal of a subpart of the data+type Trav = Exp ()++-- | What kind of traversal are we deriving?+data TraveralType = TraveralType+ { traversalArg :: Int -- ^ On what position are we traversing?+ , traversalCo :: Bool -- ^ covariant?+ , traversalName :: QName () -- ^ name of the traversal function+ , traversalId :: Trav -- ^ Identity traversal+ , traversalDirect :: Trav -- ^ Traversal of 'a'+ , traversalFunc :: QName () -> Trav -> Trav -- ^ Apply the sub-traversal function+ , traversalPlus :: Trav -> Trav -> Trav -- ^ Apply two non-identity traversals in sequence+ , traverseArrow :: Maybe (Trav -> Trav -> Trav) -- ^ Traverse a function type+ , traverseTuple :: [Exp ()] -> Exp () -- ^ Construct a tuple from applied traversals+ , traverseCtor :: String -> [Exp ()] -> Exp () -- ^ Construct a data type from applied traversals+ , traverseFunc :: Pat () -> Exp () -> Match () -- ^ Construct a clause of the traversal function+ }++defaultTraversalType = TraveralType+ { traversalArg = 1+ , traversalCo = False+ , traversalName = undefined -- prevent warnings+ , traversalId = var "id"+ , traversalDirect = var "_f"+ , traversalFunc = \x y -> appP (Var () x) y+ , traversalPlus = \x y -> apps (Con () $ Special () (Cons ())) [paren x, paren y]+ , traverseArrow = Nothing+ , traverseTuple = Tuple () Boxed+ , traverseCtor = \x y -> apps (con x) (map paren y)+ , traverseFunc = undefined+ }++data RequiredInstance = RequiredInstance+ { _requiredDataArg :: String -- ^ What argument of the current data type?+ , _requiredPosition :: Int -- ^ What argument position of that type?+ }+ deriving (Eq, Ord)++-- | Monad that collects required instances+type WithInstances a = Writer (S.Set RequiredInstance) a+++vars f c n = [f $ c : show i | i <- [1..n]]+++---------------------------------------------------------------------------------+-- Deriving traversals+++-- | Derivation for a Traversable like class with just 1 method+traversalDerivation1 :: TraveralType -> String -> Derivation+traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm)+ where className n = nm ++ (if n > 1 then show n else "")+++-- | Instance for a Traversable like class with just 1 method+traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl ()]+traversalInstance1 tt nm (_,dat)+ | isNothing (traverseArrow tt) && any isTyFun (universeBi dat) = Left $ "Can't derive " ++ prettyPrint (traversalName tt) ++ " for types with arrow"+ | dataDeclArity dat == 0 = Left "Cannot derive class for data type arity == 0"+ | otherwise = Right $ traversalInstance tt nm dat [deriveTraversal tt dat]+++-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]+-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])++-- | Instance for a Traversable like class+traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances (Decl ())] -> [Decl ()]+traversalInstance tt nameBase dat bodyM = -- [simplify $ InstDecl () Nothing [] ctx nam args (map InsDecl body)]+ [ simplify $ InstDecl () Nothing instRule (Just $ map (InsDecl ()) body) ]+ where+ instRule = IRule () Nothing (Just ctx) instHead+ instHead = foldr (flip (IHApp ())) (IHCon () nam) args+ (body, required) = runWriter (sequence bodyM)+ ctx = CxTuple ()+ [ ClassA () (qname $ className p) (tyVar n : vars tyVar 's' (p - 1))+ | RequiredInstance n p <- S.toList required+ ]+ vrs = vars tyVar 't' (dataDeclArity dat)+ (vrsBefore,_:vrsAfter) = splitAt (length vrs - traversalArg tt) vrs+ className n = nameBase ++ (if n > 1 then show n else "")+ nam = qname (className (traversalArg tt))+ args = TyParen () (tyApps (tyCon $ dataDeclName dat) vrsBefore) : vrsAfter++-- Match SrcLoc Name [Pat] (Maybe Type) Rhs (Maybe Binds)+-- Match l (Name l) [Pat l] (Rhs l) (Maybe (Binds l))+-- | Derive a 'traverse' like function+deriveTraversal :: TraveralType -> DataDecl -> WithInstances (Decl ())+deriveTraversal tt dat = fun+ where+ fun = (\xs -> FunBind () [Match () nam a b c | Match () _ a b c <- xs]) <$> body+ args = argPositions dat+ nam = unqual $ traversalNameN tt $ traversalArg tt+ body = mapM (deriveTraversalCtor tt args) (dataDeclCtors dat)++ unqual (Qual () _ x) = x+ unqual (UnQual () x) = x+++-- | Derive a clause of a 'traverse' like function for a constructor+deriveTraversalCtor :: TraveralType -> ArgPositions -> CtorDecl -> WithInstances (Match ())+deriveTraversalCtor tt ap ctor = do+ let nam = ctorDeclName ctor+ arity = ctorDeclArity ctor+ tTypes <- mapM (deriveTraversalType tt ap) (map snd $ ctorDeclFields ctor)+ return $ traverseFunc tt (PParen () $ PApp () (qname nam) (vars pVar 'a' arity))+ $ traverseCtor tt nam (zipWith (App ()) tTypes (vars var 'a' arity))++++-- | Derive a traversal for a type+deriveTraversalType :: TraveralType -> ArgPositions -> Type () -> WithInstances Trav+deriveTraversalType tt ap (TyParen () x) = deriveTraversalType tt ap x+deriveTraversalType tt ap TyForall{} = fail "forall not supported in traversal deriving"+deriveTraversalType tt ap (TyFun () a b)+ = fromJust (traverseArrow tt)+ <$> deriveTraversalType tt{traversalCo = not $ traversalCo tt} ap a+ <*> deriveTraversalType tt ap b+deriveTraversalType tt ap (TyApp () a b) = deriveTraversalApp tt ap a [b] -- T a b c ...+deriveTraversalType tt ap (TyList () a) = deriveTraversalType tt ap $ TyApp () (TyCon () $ Special () $ ListCon ()) a+deriveTraversalType tt ap (TyTuple () b a) = deriveTraversalType tt ap $ tyApps (TyCon () $ Special () $ TupleCon () b $ length a) a+deriveTraversalType tt ap (TyCon () n) = return $ traversalId tt -- T+deriveTraversalType tt ap (TyVar () (Ident () n)) -- a+ | ap n /= traversalArg tt = return $ traversalId tt+ | traversalCo tt = fail "tyvar used in covariant position"+ | otherwise = return $ traversalDirect tt+++-- | Find all arguments to a type application, then derive a traversal+deriveTraversalApp :: TraveralType -> ArgPositions -> Type () -> [Type ()] -> WithInstances Trav+deriveTraversalApp tt ap (TyApp () a b) args = deriveTraversalApp tt ap a (b : args)+deriveTraversalApp tt ap tycon@TyTuple{} args = do -- (a,b,c)+ tArgs <- mapM (deriveTraversalType tt ap) args+ return $+ if (all (== traversalId tt) tArgs) then+ traversalId tt+ else+ Lambda () [PTuple () Boxed (vars pVar 't' (length args))]+ (traverseTuple tt $ zipWith (App ()) tArgs (vars var 't' (length args)))+deriveTraversalApp tt ap tycon args = do -- T a b c+ tCon <- deriveTraversalType tt ap tycon+ tArgs <- mapM (deriveTraversalType tt ap) args+ -- need instances?+ case tycon of+ TyVar () (Ident () n) | ap n == traversalArg tt -> fail "kind error: type used type constructor"+ | otherwise -> tell $ S.fromList+ [ RequiredInstance n i+ | (t,i) <- zip (reverse tArgs) [1..]+ , t /= traversalId tt+ ]+ _ -> return ()+ -- combine non-id traversals+ let nonId = [ traverseArg tt i t+ | (t,i) <- zip (reverse tArgs) [1..]+ , t /= traversalId tt+ ]+ return $ case nonId of+ [] -> traversalId tt -- no interesting arguments to type con+ _ -> foldl1 (traversalPlus tt) nonId+++-- | Lift a traversal to the argument of a type constructor+traverseArg :: TraveralType -> Int -> Trav -> Trav+traverseArg tt n e = traversalFunc tt (traversalNameN tt n) e++traversalNameN :: TraveralType -> Int -> QName ()+traversalNameN tt n | n <= 1 = nm+ | otherwise = nm `f` (if n > 1 then show n else "")+ where nm = traversalName tt+ f (Qual () m x) y = Qual () m $ x `g` y+ f (UnQual () x) y = UnQual () $ x `g` y+ g (Ident () x) y = Ident () $ x ++ y++-- | Information on argument positions+type ArgPositions = String -> Int++-- | Position of an argument in the data type+-- In the type "data X a b c"+-- positions are: a -> 3, b -> 2, c -> 1+argPositions :: DataDecl -> String -> Int+argPositions dat = \nm -> case elemIndex nm args of+ Nothing -> error "impossible: tyvar not in scope"+ Just k -> length args - k+ where args = dataDeclVars dat
+ src/Data/Derive/Is.hs view
@@ -0,0 +1,33 @@+module Data.Derive.Is(makeIs) where+{-++test :: Sample++isFirst :: Sample a -> Bool+isFirst (First{}) = True ; isFirst _ = False++isSecond :: Sample a -> Bool+isSecond (Second{}) = True ; isSecond _ = False++isThird :: Sample a -> Bool+isThird (Third{}) = True ; isThird _ = False++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeIs :: Derivation+makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d+++makeIsCtor :: DataDecl -> CtorDecl -> [Decl ()]+makeIsCtor d c = if not $ isIdent $ ctorDeclName c then [] else+ [TypeSig () [name nam] (TyFun () (dataDeclType d) (tyCon "Bool"))+ ,FunBind () $ match : [defMatch | length (dataDeclCtors d) > 1]]+ where+ nam = "is" ++ ctorDeclName c+ + match = Match () (name nam) [PParen () $ PRec () (qname $ ctorDeclName c) []] (UnGuardedRhs () $ con "True") Nothing+ defMatch = Match () (name nam) [PWildCard ()] (UnGuardedRhs () $ con "False") Nothing
+ src/Data/Derive/JSON.hs view
@@ -0,0 +1,178 @@+-- |+-- Copyright: (c) Bertram Felgenhauer 2009+-- License: BSD3+-- Stability: experimental+-- Portability: portable+--+-- Derive 'Text.JSON' instances.+--+-- Unlike Text.JSON.Generics, single constructor types are /not/ handled+-- specially. Every value is encoded as an object with a single field,+-- with the constructor name as key and the values as its contents.+--+-- If the constructor is a record, the contents is an Object with the+-- field names as keys. Otherwise, the contents is an array.++module Data.Derive.JSON (makeJSON) where++import qualified Language.Haskell as H+import Language.Haskell (+ Exp, Pat, Alt, CtorDecl, Decl, FullDataDecl, FieldDecl, Type, Stmt,+ (~=), var, pVar, con, strE, strP, apps, qname,+ ctorDeclFields, ctorDeclName, dataDeclCtors)++{-+import "json" Text.JSON+import Text.JSON.Types++example :: Custom+instance JSON a => JSON (Sample a) where+ readJSON (JSObject x) = $(readJSON)+ readJSON _ = Error "..."+ showJSON (First) = $(showJSON 0)+ showJSON (Second x1 x2) = $(showJSON 1)+ showJSON (Third x1) = $(showJSON 2)+-}++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeJSON :: Derivation+makeJSON = derivationCustomDSL "JSON" custom $+ List [Instance ["JSON"] "JSON" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),List [App "Match" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),String "readJSON"]),List [App "PParen" (+ List [App "()" (List []),App "PApp" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "JSObject"])]),List [App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "x"])])]])])+ ],App "UnGuardedRhs" (List [App "()" (List []),App "SpliceExp" (+ List [App "()" (List []),App "ParenSplice" (List [App "()" (List [+ ]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "readJSON"])])])])])]),App "Nothing" (List [])]),App "Match" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "readJSON"]),List [App "PWildCard" (List [App "()" (List [])])],+ App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Con" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "Error"])])]),App "Lit" (List [App "()" (List []),App+ "String" (List [App "()" (List []),String "...",String "..."])])])+ ]),App "Nothing" (List [])])]])]),App "InsDecl" (List [App "()" (+ List []),App "FunBind" (List [App "()" (List []),MapCtor (App+ "Match" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "showJSON"]),List [App "PParen" (List [App "()" (+ List []),App "PApp" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),CtorName]+ )]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),Concat (List [String "x",ShowInt+ FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []+ ),App "SpliceExp" (List [App "()" (List []),App "ParenSplice" (+ List [App "()" (List []),App "App" (List [App "()" (List []),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "showJSON"])])]),+ App "Lit" (List [App "()" (List []),App "Int" (List [App "()" (+ List []),CtorIndex,ShowInt CtorIndex])])])])])]),App "Nothing" (+ List [])]))])])]]))]+-- GENERATED STOP++-- ^ 'Derivation' for 'JSON'++custom :: FullDataDecl -> [Decl ()] -> [Decl ()]+custom = customSplice splice++splice :: FullDataDecl -> Exp () -> Exp ()+splice d x | x ~= "readJSON" = mkRead d+splice d (H.App _ x (H.Lit _ (H.Int _ y _))) | x~= "showJSON" = mkShow d y+splice _ e = error $ "makeJSON: unrecognized splice: " ++ show e++------------------------------------------------------------------------------+-- showJSON++mkShow :: FullDataDecl -> Integer -> Exp ()+mkShow d y = let+ hasFields = any (not . null . fst) (ctorDeclFields c)+ c = dataDeclCtors (snd d) !! fromInteger y+ mkFields = if hasFields then mkShowRecordFields else mkShowPlainFields+ in+ mkJSObject $ H.List ()+ [H.Tuple () H.Boxed [strE (ctorDeclName c), mkFields (ctorDeclFields c)]]++mkShowPlainFields :: FieldDecl -> Exp ()+mkShowPlainFields fs = mkJSArray $ H.List ()+ [H.App () (var "showJSON") xi | xi <- vars "x" fs]++mkShowRecordFields :: FieldDecl -> Exp ()+mkShowRecordFields fs = mkJSObject $ H.List ()+ [ H.Tuple () H.Boxed [strE fn, H.App () (var "showJSON") xi]+ | ((fn, _), xi) <- zip fs (vars "x" fs)]++------------------------------------------------------------------------------+-- readJSON++mkRead :: FullDataDecl -> Exp ()+mkRead (_, d) = let+ readError = H.App () (con "Error") $ strE "malformed JSON for type ...: ..."+ in+ H.Case () (H.App () (var "fromJSObject") $ var "x") $+ map mkReadCtor (dataDeclCtors d) +++ [H.Alt () (H.PWildCard ()) (H.UnGuardedRhs () readError) Nothing]++mkReadCtor :: CtorDecl -> Alt ()+mkReadCtor c = let+ cn = ctorDeclName c+ fs = ctorDeclFields c+ hasFields = any (not . null . fst) fs+ body | hasFields = mkReadRecord cn fs+ | otherwise = mkReadPlain cn fs+ in+ H.Alt () (H.PList () [H.PTuple () H.Boxed [strP cn, pVar "y"]])+ (H.UnGuardedRhs () body) Nothing++mkReadRecord :: String -> FieldDecl -> Exp ()+mkReadRecord cn fs = H.Do () $+ [H.Generator () (H.PApp () (qname "JSObject") [pVar "z"])+ (H.App () (var "return") $ var "y")] +++ [H.LetStmt () $ H.BDecls () [H.PatBind () (pVar "d")+ (H.UnGuardedRhs () $ H.App () (var "fromJSObject") $ var "z")+ Nothing]] +++ zipWith (mkReadRecordField cn) (pVars "x" fs) fs +++ mkReadTrailer cn fs++mkReadRecordField :: String -> Pat () -> (String, Type ()) -> Stmt ()+mkReadRecordField cn xi (fn, _) = H.Generator () xi $+ apps (var "maybe") [+ H.App () (var "fail") $ strE (unwords ["readJSON: missing field", fn,+ "while decoding a", cn]),+ var "return",+ apps (var "lookup") [strE fn, var "d"]]++mkReadPlain :: String -> FieldDecl -> Exp ()+mkReadPlain cn fs = H.Do () $+ [H.Generator () (H.PApp () (qname "JSArray") [H.PList () (pVars "x" fs)])+ (H.App () (var "return") $ var "y")] +++ mkReadTrailer cn fs++mkReadTrailer :: String -> FieldDecl -> [Stmt ()]+mkReadTrailer cn fs =+ [ H.Generator () yi (H.App () (var "readJSON") xi)+ | (xi, yi) <- zip (vars "x" fs) (pVars "y" fs)] +++ [H.Qualifier () $ H.App () (var "return") $ apps (con cn) (vars "y" fs)]++------------------------------------------------------------------------------+-- utilites++mkJSObject :: Exp () -> Exp ()+mkJSObject e = H.App () (con "JSObject") (H.App () (var "toJSObject") e)++mkJSArray :: Exp () -> Exp ()+mkJSArray e = H.App () (con "JSArray") e++vars :: String -> FieldDecl -> [Exp ()]+vars pre fs = [var (pre ++ show i) | i <- [1..length fs]]++pVars :: String -> FieldDecl -> [Pat ()]+pVars pre fs = [pVar (pre ++ show i) | i <- [1..length fs]]
+ src/Data/Derive/LazySet.hs view
@@ -0,0 +1,39 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @LazySet@ generates a function like a record updator, but lazy where possible.+ This is very useful in certain situations to improve laziness+ properties. A setter is only lazy if that field is present in one constructor.+-}+module Data.Derive.LazySet(makeLazySet) where+{-++test :: Computer++setSpeed :: Int -> Computer -> Computer+setSpeed v x = x{speed=v}++setWeight :: Double -> Computer -> Computer+setWeight v x = Laptop v (speed x)++test :: Sample++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeLazySet :: Derivation+makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d+++makeLazySetField :: DataDecl -> String -> [Decl ()]+makeLazySetField d field = if isIdent field then [TypeSig () [name fun] typ, bind fun [pVar "v",pVar "x"] bod] else []+ where+ fun = "set" ++ title field+ tyFun = TyFun ()+ typ = t `tyFun` (dataDeclType d `tyFun` dataDeclType d)+ (t,c):tc = [(t,c) | c <- dataDeclCtors d, (n,t) <- ctorDeclFields c, n == field]++ bod | null tc = apps (con $ ctorDeclName c) [n == field ? var "v" $ Paren () $ App () (var n) (var "x") | (n,t) <- ctorDeclFields c]+ | otherwise = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]
+ src/Data/Derive/Lens.hs view
@@ -0,0 +1,41 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @Lens@ generates @lens@/FieldName/@ = lens @/fieldName/@+ (\ x v -> v { @/fieldName/@ = x })@.++ This works with the @data-lens@ package.+-}+module Data.Derive.Lens(makeLens) where++{-+import "data-lens" Data.Lens.Common++test :: Sample++test :: Computer++lensSpeed :: Lens Computer Int+lensSpeed = lens speed (\x v -> v{speed = x})++lensWeight :: Lens Computer Double+lensWeight = lens weight (\x v -> v{weight = x})+-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeLens :: Derivation+makeLens = derivationCustom "Lens" $ \(_,d) -> Right $ concatMap (makeLensField d) $ dataDeclFields d+++makeLensField :: DataDecl -> String -> [Decl ()]+makeLensField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []+ where+ ref = "lens" ++ title field+ typ = tyApps (tyCon "Lens") [dataDeclType d, t]+ Just t = lookup field $ concatMap ctorDeclFields $ dataDeclCtors d++ bod = apps (var "lens")+ [var field+ ,Paren () $ Lambda () [pVar "x",pVar "v"] $ RecUpdate () (var "v") [FieldUpdate () (qname field) (var "x")]]
+ src/Data/Derive/Monoid.hs view
@@ -0,0 +1,93 @@+{-|+ Derives an instance of @Monoid@. It uses the product+ construction of monoids. @mappend@ on two different constructors+ is undefined.+-}+module Data.Derive.Monoid(makeMonoid) where+{-+import Data.Monoid hiding (First)++example :: Sample+instance Monoid a => Monoid (Sample a) where+ mempty = head [First, Second (const mempty 1) (const mempty 2), Third (const mempty 1)]+ mappend (First) (First) = First+ mappend (Second x1 x2) (Second y1 y2) = Second (mappend x1 y1) (mappend x2 y2)+ mappend (Third x1) (Third y1) = Third (mappend x1 y1)+ mappend _ _ | length [First{},Second{},Third{}] > 1 = error "Monoid.mappend: Different constructors for Sample"++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeMonoid :: Derivation+makeMonoid = derivationDSL "Monoid" dslMonoid++dslMonoid =+ List [Instance ["Monoid"] "Monoid" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "mempty"])]),App "UnGuardedRhs" (List [+ App "()" (List []),App "App" (List [App "()" (List []),App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "head"])])]),App+ "List" (List [App "()" (List []),MapCtor (Application (Concat (+ List [List [App "Con" (List [App "()" (List []),App "UnQual" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+ ])])])],MapField (App "Paren" (List [App "()" (List []),+ Application (List [App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "const"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "mempty"])])]),App "Lit" (List [App "()" (List []+ ),App "Int" (List [App "()" (List []),FieldIndex,ShowInt+ FieldIndex])])])]))])))])])]),App "Nothing" (List [])])]),App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),Concat (List [MapCtor (App "Match" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "mappend"]),List+ [App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))])]),App "PParen" (List [App+ "()" (List []),App "PApp" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])]),MapField (App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),Concat (List [String "y",ShowInt+ FieldIndex])])]))])])],App "UnGuardedRhs" (List [App "()" (List []+ ),Application (Concat (List [List [App "Con" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),CtorName])])])],MapField (App "Paren" (List [App+ "()" (List []),Application (List [App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "mappend"])])]),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]+ )])]),App "Var" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "y",ShowInt FieldIndex])])])])])]))]))]),App "Nothing" (+ List [])])),List [App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "mappend"]),List [App+ "PWildCard" (List [App "()" (List [])]),App "PWildCard" (List [App+ "()" (List [])])],App "GuardedRhss" (List [App "()" (List []),List+ [App "GuardedRhs" (List [App "()" (List []),List [App "Qualifier"+ (List [App "()" (List []),App "InfixApp" (List [App "()" (List [])+ ,App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "length"])])]),App "List" (List [App+ "()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+ List [App "()" (List []),String ">"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])])],App "App" (List [App "()" (List []),App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "error"])])]),App+ "Lit" (List [App "()" (List []),App "String" (List [App "()" (List+ []),Concat (List [String+ "Monoid.mappend: Different constructors for ",DataName]),Concat (+ List [String "Monoid.mappend: Different constructors for ",+ DataName])])])])])]]),App "Nothing" (List [])])]])])])]]))]+-- GENERATED STOP
+ src/Data/Derive/NFData.hs view
@@ -0,0 +1,42 @@+module Data.Derive.NFData where+{-+import "deepseq" Control.DeepSeq(NFData, rnf)++example :: Sample+instance NFData a => NFData (Sample a) where+ rnf (First) = ()+ rnf (Second x1 x2) = rnf x1 `seq` rnf x2 `seq` ()+ rnf (Third x1) = rnf x1 `seq` ()++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeNFData :: Derivation+makeNFData = derivationDSL "NFData" dslNFData++dslNFData =+ List [Instance ["NFData"] "NFData" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "FunBind" (List [App "()"+ (List []),MapCtor (App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "rnf"]),List [App+ "PParen" (List [App "()" (List []),App "PApp" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (+ List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (+ List []),Head,App "QVarOp" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "seq"])])]),Tail])) (Concat (List [MapField (App "App" (+ List [App "()" (List []),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "rnf"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),Concat (List [String "x",ShowInt FieldIndex])])])])])),+ List [App "Con" (List [App "()" (List []),App "Special" (List [App+ "()" (List []),App "UnitCon" (List [App "()" (List [])])])])]]))])+ ,App "Nothing" (List [])]))])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Ref.hs view
@@ -0,0 +1,42 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @Ref@ generates @ref@/FieldName/@ = Ref { select = @/fieldName/@ , update =+ \ f v -> v { @/fieldName/@ = f (@/fieldName/@ v) } }@.++ This is intended for use with the compositional functional references+ described in+ <http://www.haskell.org/pipermail/haskell-cafe/2007-June/026477.html>.+-}+module Data.Derive.Ref(makeRef) where++{-+test :: Sample++test :: Computer++refSpeed :: Ref Computer+refSpeed = Ref {select = speed, update = \f v -> v{speed = f (speed v)}}++refWeight :: Ref Computer+refWeight = Ref {select = weight, update = \f v -> v{weight = f (weight v)}}+-}++import Language.Haskell+import Data.Derive.Internal.Derivation+++makeRef :: Derivation+makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d+++makeRefField :: DataDecl -> String -> [Decl ()]+makeRefField d field = if isIdent field then [TypeSig () [name ref] typ, bind ref [] bod] else []+ where+ ref = "ref" ++ title field+ typ = TyApp () (tyCon "Ref") (dataDeclType d)++ bod = RecConstr () (qname "Ref")+ [FieldUpdate () (qname "select") (var field)+ ,FieldUpdate () (qname "update") $ Lambda () [pVar "f",pVar "v"] $+ RecUpdate () (var "v") [FieldUpdate () (qname field) $ App () (var "f") $ Paren () $ App () (var field) (var "v")]+ ]
+ src/Data/Derive/Serial.hs view
@@ -0,0 +1,84 @@+module Data.Derive.Serial where+{-+import "smallcheck" Test.SmallCheck++example :: Sample++instance Serial a => Serial (Sample a) where+ series = cons0 First \/+ cons2 Second \/+ cons1 Third++ coseries rs d = [ \t -> case t of+ First -> t0+ Second x1 x2 -> t1 x1 x2+ Third x1 -> t2 x1+ | t0 <- alts0 rs d `const` First{}+ , t1 <- alts2 rs d `const` Second{}+ , t2 <- alts1 rs d `const` Third{}+ ]++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeSerial :: Derivation+makeSerial = derivationDSL "Serial" dslSerial++dslSerial =+ List [Instance ["Serial"] "Serial" (App "Just" (List [List [App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "series"])]),App "UnGuardedRhs" (List [+ App "()" (List []),Fold (App "InfixApp" (List [App "()" (List []),+ Tail,App "QVarOp" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Symbol" (List [App "()" (List []),String+ "\\/"])])]),Head])) (Reverse (MapCtor (App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),Concat (+ List [String "cons",ShowInt CtorArity])])])]),App "Con" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),CtorName])])])]))))]),App "Nothing" (+ List [])])]),App "InsDecl" (List [App "()" (List []),App "FunBind"+ (List [App "()" (List []),List [App "Match" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "coseries"]),List+ [App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "rs"])]),App "PVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "d"])])],App+ "UnGuardedRhs" (List [App "()" (List []),App "ListComp" (List [App+ "()" (List []),App "Lambda" (List [App "()" (List []),List [App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "t"])])],App "Case" (List [App "()" (List []),App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "t"])])]),MapCtor (+ App "Alt" (List [App "()" (List []),App "PApp" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))]),App "UnGuardedRhs" (List [+ App "()" (List []),Application (Concat (List [List [App "Var" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),Concat (List [String "t",+ ShowInt CtorIndex])])])])],MapField (App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),Concat (List [String "x",ShowInt FieldIndex])]+ )])]))]))]),App "Nothing" (List [])]))])]),MapCtor (App "QualStmt"+ (List [App "()" (List []),App "Generator" (List [App "()" (List []+ ),App "PVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),Concat (List [String "t",ShowInt CtorIndex])])]),App+ "InfixApp" (List [App "()" (List []),Application (List [App "Var"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),Concat (List [String "alts",+ ShowInt CtorArity])])])]),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "rs"])])]),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "d"])])])]),App "QVarOp" (List [App "()" (List [])+ ,App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "const"])])]),App "RecConstr" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),CtorName])]),List []])])])]))])]),App+ "Nothing" (List [])])]])])]]))]+-- GENERATED STOP
+ src/Data/Derive/Serialize.hs view
@@ -0,0 +1,182 @@+module Data.Derive.Serialize where+{-+import "cereal" Data.Serialize++example :: Sample++instance Serialize alpha => Serialize (Sample alpha) where+ put x = case x of+ First -> do putTag 0+ Second x1 x2 -> do putTag 1 ; put x1 ; put x2+ Third x1 -> do putTag 2 ; put x1+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ putTag x = when useTag (putWord8 x)++ get = do+ i <- getTag+ case i of+ 0 -> do return (First)+ 1 -> do x1 <- get ; x2 <- get ; return (Second x1 x2)+ 2 -> do x1 <- get ; return (Third x1)+ _ -> error "Corrupted binary data for Sample"+ where+ useTag = length [First{}, Second{}, Third{}] > 1+ getTag = if useTag then getWord8 else return 0+++test :: List++instance Serialize a => Serialize (List a) where+ put x = case x of+ Nil -> putWord8 0+ Cons x1 x2 -> do putWord8 1; put x1; put x2++ get = do+ i <- getWord8+ case i of+ 0 -> return Nil+ 1 -> do x1 <- get; x2 <- get; return (Cons x1 x2)+ _ -> error "Corrupted binary data for List"++test :: Assoced++instance Serialize typ => Serialize (Assoced typ) where+ put (Assoced x1 x2) = do put x1; put x2+ get = do x1 <- get; x2 <- get; return (Assoced x1 x2)+++-}+-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeSerialize :: Derivation+makeSerialize = derivationDSL "Serialize" dslSerialize++dslSerialize =+ List [Instance ["Serialize"] "Serialize" (App "Just" (List [List [+ App "InsDecl" (List [App "()" (List []),App "FunBind" (List [App+ "()" (List []),List [App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "put"]),List [App "PVar"+ (List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),App+ "Case" (List [App "()" (List []),App "Var" (List [App "()" (List [+ ]),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "x"])])]),MapCtor (App "Alt" (List [App "()"+ (List []),App "PApp" (List [App "()" (List []),App "UnQual" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),CtorName+ ])]),MapField (App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),Concat (List [String "x",ShowInt+ FieldIndex])])]))]),App "UnGuardedRhs" (List [App "()" (List []),+ App "Do" (List [App "()" (List []),Concat (List [List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "putTag"])])]),App "Lit" (List [App "()" (List []),App "Int" (List+ [App "()" (List []),CtorIndex,ShowInt CtorIndex])])])])],MapField+ (App "Qualifier" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "put"])])]),App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),Concat (List [String "x",ShowInt FieldIndex])])])])])]))]+ )])]),App "Nothing" (List [])]))])]),App "Just" (List [App+ "BDecls" (List [App "()" (List []),List [App "PatBind" (List [App+ "()" (List []),App "PVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),String "useTag"])]),App "UnGuardedRhs" (+ List [App "()" (List []),App "InfixApp" (List [App "()" (List []),+ App "App" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "length"])])]),App "List" (List [App+ "()" (List []),MapCtor (App "RecConstr" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),CtorName])]),List []]))])]),App "QVarOp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Symbol" (+ List [App "()" (List []),String ">"])])]),App "Lit" (List [App+ "()" (List []),App "Int" (List [App "()" (List []),Int 1,ShowInt (+ Int 1)])])])]),App "Nothing" (List [])]),App "FunBind" (List [App+ "()" (List []),List [App "Match" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "putTag"]),List [App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "x"])])],App "UnGuardedRhs" (List [App "()" (List []),+ Application (List [App "Var" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "when"])])]),App "Var" (List [App "()" (List []),+ App "UnQual" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "useTag"])])]),App "Paren" (List [App "()" (List+ []),App "App" (List [App "()" (List []),App "Var" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),Concat (List [String "putWord",ShowInt (Int 8)+ ])])])]),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "x"])])])])])])]),App "Nothing" (List [])])]])]])])])]])]),App+ "InsDecl" (List [App "()" (List []),App "PatBind" (List [App "()"+ (List []),App "PVar" (List [App "()" (List []),App "Ident" (List [+ App "()" (List []),String "get"])]),App "UnGuardedRhs" (List [App+ "()" (List []),App "Do" (List [App "()" (List []),List [App+ "Generator" (List [App "()" (List []),App "PVar" (List [App "()" (+ List []),App "Ident" (List [App "()" (List []),String "i"])]),App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),String "getTag"])])])]),+ App "Qualifier" (List [App "()" (List []),App "Case" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "i"])])]),Concat (List [MapCtor (App "Alt" (List [App "()"+ (List []),App "PLit" (List [App "()" (List []),App "Signless" (+ List [App "()" (List [])]),App "Int" (List [App "()" (List []),+ CtorIndex,ShowInt CtorIndex])]),App "UnGuardedRhs" (List [App "()"+ (List []),App "Do" (List [App "()" (List []),Concat (List [+ MapField (App "Generator" (List [App "()" (List []),App "PVar" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ Concat (List [String "x",ShowInt FieldIndex])])]),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "get"])])])])),List [App+ "Qualifier" (List [App "()" (List []),App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "return"])])]),App "Paren" (List [App "()" (List []),Application (+ Concat (List [List [App "Con" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),CtorName])])])],MapField (App "Var" (List [App "()" (List+ []),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),Concat (List [String "x",ShowInt FieldIndex])])])])+ )]))])])])]])])]),App "Nothing" (List [])])),List [App "Alt" (List+ [App "()" (List []),App "PWildCard" (List [App "()" (List [])]),+ App "UnGuardedRhs" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "error"])])]),App "Lit" (List [App "()" (List []),App+ "String" (List [App "()" (List []),Concat (List [String+ "Corrupted binary data for ",DataName]),Concat (List [String+ "Corrupted binary data for ",DataName])])])])]),App "Nothing" (+ List [])])]])])])]])]),App "Just" (List [App "BDecls" (List [App+ "()" (List []),List [App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "useTag"])]),App "UnGuardedRhs" (List [App "()" (List [+ ]),App "InfixApp" (List [App "()" (List []),App "App" (List [App+ "()" (List []),App "Var" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ String "length"])])]),App "List" (List [App "()" (List []),MapCtor+ (App "RecConstr" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),CtorName])]),+ List []]))])]),App "QVarOp" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String ">"])])]),App "Lit" (List [App "()" (List []),App "Int" (+ List [App "()" (List []),Int 1,ShowInt (Int 1)])])])]),App+ "Nothing" (List [])]),App "PatBind" (List [App "()" (List []),App+ "PVar" (List [App "()" (List []),App "Ident" (List [App "()" (List+ []),String "getTag"])]),App "UnGuardedRhs" (List [App "()" (List [+ ]),App "If" (List [App "()" (List []),App "Var" (List [App "()" (+ List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),String "useTag"])])]),App "Var" (List [App+ "()" (List []),App "UnQual" (List [App "()" (List []),App "Ident"+ (List [App "()" (List []),Concat (List [String "getWord",ShowInt (+ Int 8)])])])]),App "App" (List [App "()" (List []),App "Var" (List+ [App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "return"])])]),App "Lit"+ (List [App "()" (List []),App "Int" (List [App "()" (List []),Int+ 0,ShowInt (Int 0)])])])])]),App "Nothing" (List [])])]])])])])]]))+ ]+-- GENERATED STOP
+ src/Data/Derive/Set.hs view
@@ -0,0 +1,41 @@+{-|+ A pseudo derivation. For each field in the data type, deriving+ @Set@ generates @set@/FieldName/@ v x = x{@/fieldName/@ = v}@.+ This derivation is intended to work around the fact that in Haskell+ assigning to a field is not a first class object (although+ extracting from a field is).+-}+module Data.Derive.Set(makeSet) where++{-++test :: Computer++setSpeed :: Int -> Computer -> Computer+setSpeed v x = x{speed=v}++setWeight :: Double -> Computer -> Computer+setWeight v x = x{weight=v}++test :: Sample++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe+++makeSet :: Derivation+makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d+++makeSetField :: DataDecl -> String -> [Decl ()]+makeSetField d field = [TypeSig () [name set] typ, bind set [pVar "v",pVar "x"] bod]+ where+ set = "set" ++ title field+ tyFun = TyFun ()+ typ = typField `tyFun` (dataDeclType d `tyFun` dataDeclType d)+ typField = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d++ bod = RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]
+ src/Data/Derive/UniplateDirect.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE PatternGuards #-}+-- NOTE: Cannot be guessed as it relies on type information++-- | Derive Uniplate and Biplate using the Direct combinators.+-- You must request monomorphic instances, i.e:+--+-- > data Foo a = Foo a (Bool, a)+-- >+-- > {-!+-- > deriving instance UniplateDirect (Foo Int)+-- > deriving instance UniplateDirect (Bool, Int) Int+-- > deriving instance UniplateDirect (Foo Int) Int+-- > !-}+--+-- This will generate the instances @Uniplate (Foo Int)@,+-- @Biplate (Bool, Int) Int@ and @Biplate (Foo Int) Int@.+-- Generally, start with the instance you are after (e.g. @UniplateDirect (Foo Int)@),+-- try to compile and add further instances as necessary. @UniplateDirect@ with+-- one argument derives Uniplate, and with two arguments derives Biplate.+--+-- @deriving UniplateDirect@ on a data type with no arguments derives Uniplate+-- with all type parameters defaulting to @()@.+module Data.Derive.UniplateDirect(makeUniplateDirect) where+++{-+import "uniplate" Data.Generics.Uniplate.Direct+++-- test tuples+test :: UniplateDirect ((), Maybe ()) ()+instance Biplate ((), Maybe ()) () where+ {-# INLINE biplate #-}+ biplate (x1, x2) = plate (,) |* x1 |+ x2++test :: UniplateDirect (Sample Int)+instance Uniplate (Sample Int) where+ {-# INLINE uniplate #-}+ uniplate x = plate x++test :: UniplateDirect (Sample Int) Int+instance Biplate (Sample Int) Int where+ {-# INLINE biplate #-}+ biplate (Second x1 x2) = plate Second |* x1 |* x2+ biplate (Third x1) = plate Third |* x1+ biplate x = plate x++test :: UniplateDirect Computer+instance Uniplate Computer where+ {-# INLINE uniplate #-}+ uniplate x = plate x++test :: UniplateDirect Computer Computer+instance Biplate Computer Computer where+ {-# INLINE biplate #-}+ biplate = plateSelf++test :: UniplateDirect Computer Double+instance Biplate Computer Double where+ {-# INLINE biplate #-}+ biplate (Laptop x1 x2) = plate Laptop |* x1 |- x2+ biplate x = plate x++test :: UniplateDirect (Assoced (Maybe Bool)) Char+instance Biplate (Assoced (Maybe Bool)) Char where+ {-# INLINE biplate #-}+ biplate (Assoced x1 x2) = plate (Assoced x1) ||* x2++-- test following external declarations+test :: UniplateDirect (Either Bool Computer) Int+instance Biplate (Either Bool Computer) Int where+ {-# INLINE biplate #-}+ biplate (Right x1) = plate Right |+ x1+ biplate x = plate x++-- test recursive bits+test :: UniplateDirect (List Int) Bool+instance Biplate (List Int) Bool where+ {-# INLINE biplate #-}+ biplate x = plate x+-}++import Language.Haskell+import Data.Generics.Uniplate.DataOnly+import Data.Derive.Internal.Derivation+import Data.Maybe+import qualified Data.Map as Map+import Control.Arrow+import Control.Monad.Trans.State+++makeUniplateDirect :: Derivation+makeUniplateDirect = derivationParams "UniplateDirect" $ \args grab (_,ty) -> simplify $+ let known = map (declName &&& id) knownCtors+ grab2 x = fromMaybe (grab x) $ lookup x known+ in case args of+ _ | not $ null [() | TyVar () _ <- universeBi args] -> error "UniplateDirect only accepts monomorphic types"+ [] -> make True grab2 x x+ where x = tyApps (tyCon $ dataDeclName ty) $ replicate (dataDeclArity ty) $ TyCon () $ Special () (UnitCon ())+ [x] -> make True grab2 x x+ [x,y] -> make False grab2 x y+ _ -> error $ "UniplateDirect requires exactly one or two arguments, got " ++ show (length args)++-- alwaysActive :: Activation ()+-- alwaysActive = ActiveFrom () 0++make :: Bool -> (String -> DataDecl) -> Type () -> Type () -> Either String [Decl ()]+make uni grab from to =+ Right [InstDecl () Nothing instRule+ (Just [InsDecl () $ InlineSig () True Nothing (qname $ if uni then "uniplate" else "biplate"), InsDecl () ms])]+ where+ headName = (UnQual () $ Ident () $ if uni then "Uniplate" else "Biplate")+ instRule = IRule () Nothing Nothing (foldr (flip (IHApp ())) (IHCon () headName) (from : [to | not uni]))+ ty = grab $ tyRoot from+ match pat bod = Match () (Ident () $ if uni then "uniplate" else "biplate") [pat] (UnGuardedRhs () bod) Nothing+ ms = if uni || from /= to+ then FunBind () $ map (uncurry match) (catMaybes bods) ++ [match (pVar "x") (App () (var "plate") (var "x")) | any isNothing bods]+ else PatBind () (pVar "biplate") (UnGuardedRhs () $ var "plateSelf") Nothing+ bods = run (fromTyParens to) $ mapM (make1 grab) $ substData from ty+++make1 :: (String -> DataDecl) -> (String,[Type ()]) -> S (Maybe (Pat (), Exp ()))+make1 grab (name,tys) = do+ ops <- mapM (fmap show . operator grab) tys+ let vars = ['x':show i | i <- [1..length tys]]+ pat = PParen () $ PApp () (qname name) $ map pVar vars+ (good,bad) = span ((==) "|-" . fst) $ zip ops $ map var vars+ bod = foldl (\x (y,z) -> InfixApp () x (QVarOp () $ UnQual () $ Symbol () y) z) (App () (var "plate") $ paren $ apps (con name) (map snd good)) bad+ return $ if all (== "|-") ops then Nothing else Just (pat,bod)+++data Ans = Hit | Miss | Try | ListHit | ListTry deriving Eq++instance Show Ans where+ show Hit = "|*"+ show Miss = "|-"+ show Try = "|+"+ show ListHit = "||*"+ show ListTry = "||+"++ansList Hit = ListHit+ansList Miss = Miss+ansList _ = ListTry+++ansJoin (Miss:xs) = ansJoin xs+ansJoin [] = Miss+ansJoin _ = Try+++type S a = State (Map.Map (Type ()) Ans) a++run :: Type () -> S a -> a+run to act = evalState act (Map.singleton to Hit)++operator :: (String -> DataDecl) -> Type () -> S Ans+operator grab from = do+ mp <- get+ case Map.lookup from mp of+ Just y -> return y+ Nothing -> do+ fix Miss+ where+ fix ans = do+ s <- get+ modify $ Map.insert from ans+ ans2 <- operator2 grab from+ if ans == ans2+ then return ans+ else put s >> fix ans2+++operator2 :: (String -> DataDecl) -> Type () -> S Ans+operator2 grab from+ | isTyFun from = return Try+ | Just from2 <- fromTyList from = fmap ansList $ operator grab from2+ | otherwise = case subst from $ grab $ tyRoot from of+ Left from2 -> operator grab from2+ Right ctrs -> fmap ansJoin $ mapM (operator grab) $ concatMap snd ctrs+++subst :: Type () -> Decl () -> Either (Type ()) [(String,[Type ()])]+subst ty x@TypeDecl{} = Left $ substType ty x+subst ty x = Right $ substData ty x++substData :: Type () -> Decl () -> [(String,[Type ()])]+substData ty dat = [(ctorDeclName x, map (fromTyParens . transform f . snd) $ ctorDeclFields x) | x <- dataDeclCtors dat]+ where+ rep = zip (dataDeclVars dat) (snd $ fromTyApps $ fromTyParen ty)+ f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep+ f x = x++substType :: Type () -> Decl () -> Type ()+substType ty (TypeDecl () dhead d) = fromTyParens $ transform f d+ where+ vars = collect dhead+ rep = zip (map prettyPrint vars) (snd $ fromTyApps ty)+ f (TyVar () x) = fromMaybe (TyVar () x) $ lookup (prettyPrint x) rep+ f x = x+ collect (DHead () _) = []+ collect (DHInfix () bind _) = [bind]+ collect (DHParen () h) = collect h+ collect (DHApp () h bind) = bind : collect h++clearAnn :: Functor f => f a -> f ()+clearAnn = fmap (const ())++knownCtors :: [Decl ()]+knownCtors = map (fromParseResult . fmap clearAnn . parseDecl)+ ["data Int = Int"+ ,"data Bool = Bool"+ ,"data Char = Char"+ ,"data Double = Double"+ ,"data Float = Float"+ ,"data Integer = Integer"+ ,"data Maybe a = Nothing | Just a"+ ,"data Either a b = Left a | Right b"+ ,"type Rational = Ratio Integer"+ ,"data (Integral a) => Ratio a = !a :% !a"+ ,"type String = [Char]"+ ] +++ listCtor :+ map tupleDefn (0:[2..32])++listCtor = DataDecl () (DataType ()) Nothing (DHApp () (DHead () $ Ident () "[]") (UnkindedVar () $ Ident () "a"))+ [QualConDecl () Nothing Nothing $ ConDecl () (Ident () "[]") []+ ,QualConDecl () Nothing Nothing $ ConDecl () (Ident () "(:)") [tyVar "a", TyList () $ tyVar "a"]] []++tupleDefn :: Int -> Decl ()+tupleDefn n = DataDecl () (DataType ()) Nothing dhead [QualConDecl () Nothing Nothing $ ConDecl () (Ident () s) (map tyVar vars)] []+ where s = "(" ++ replicate (n - 1) ',' ++ ")"+ vars = ['v':show i | i <- [1..n]]+ dhead = foldr (flip (DHApp ())) (DHead () $ Ident () s) (map (UnkindedVar () . Ident ()) vars)
+ src/Data/Derive/UniplateTypeable.hs view
@@ -0,0 +1,102 @@+module Data.Derive.UniplateTypeable where+{-+import "uniplate" Data.Generics.Uniplate.Typeable++example :: Custom++instance (Typeable a, PlateAll a to, Uniplate to, Typeable to) => PlateAll (Sample a) to where+ plateAll (First) = plate First+ plateAll (Second x1 x2) = plate Second |+ x1 |+ x2+ plateAll (Third x1) = plate Third |+ x1++test :: Bool++instance (Typeable to, Uniplate to) => PlateAll Bool to where+ plateAll False = plate False+ plateAll True = plate True++test :: Either a b++instance (Typeable a, PlateAll a to, Typeable b, PlateAll b to, Typeable to, Uniplate to) => PlateAll (Either a b) to where+ plateAll (Left x1) = plate Left |+ x1+ plateAll (Right x1) = plate Right |+ x1++-}++import Data.Derive.DSL.HSE++-- GENERATED START++import Data.Derive.DSL.DSL+import Data.Derive.Internal.Derivation++makeUniplateTypeable :: Derivation+makeUniplateTypeable = derivationCustomDSL "UniplateTypeable" custom $+ List [App "InstDecl" (List [App "()" (List []),App "Nothing" (List+ []),App "IRule" (List [App "()" (List []),App "Nothing" (List []),+ App "Just" (List [App "CxTuple" (List [App "()" (List []),List [+ App "ClassA" (List [App "()" (List []),App "UnQual" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String+ "Typeable"])]),List [App "TyVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "a"])])]]),App "ClassA" (+ List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "PlateAll"])]),List [+ App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "a"])]),App "TyVar" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),String "to"])])]]),App "ClassA"+ (List [App "()" (List []),App "UnQual" (List [App "()" (List []),+ App "Ident" (List [App "()" (List []),String "Uniplate"])]),List [+ App "TyVar" (List [App "()" (List []),App "Ident" (List [App "()"+ (List []),String "to"])])]]),App "ClassA" (List [App "()" (List []+ ),App "UnQual" (List [App "()" (List []),App "Ident" (List [App+ "()" (List []),String "Typeable"])]),List [App "TyVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),String "to"])+ ])]])]])]),App "IHApp" (List [App "()" (List []),App "IHApp" (List+ [App "()" (List []),App "IHCon" (List [App "()" (List []),App+ "UnQual" (List [App "()" (List []),App "Ident" (List [App "()" (+ List []),String "PlateAll"])])]),App "TyParen" (List [App "()" (+ List []),App "TyApp" (List [App "()" (List []),App "TyCon" (List [+ App "()" (List []),App "UnQual" (List [App "()" (List []),App+ "Ident" (List [App "()" (List []),DataName])])]),App "TyVar" (List+ [App "()" (List []),App "Ident" (List [App "()" (List []),String+ "a"])])])])]),App "TyVar" (List [App "()" (List []),App "Ident" (+ List [App "()" (List []),String "to"])])])]),App "Just" (List [+ List [App "InsDecl" (List [App "()" (List []),App "FunBind" (List+ [App "()" (List []),MapCtor (App "Match" (List [App "()" (List [])+ ,App "Ident" (List [App "()" (List []),String "plateAll"]),List [+ App "PParen" (List [App "()" (List []),App "PApp" (List [App "()"+ (List []),App "UnQual" (List [App "()" (List []),App "Ident" (List+ [App "()" (List []),CtorName])]),MapField (App "PVar" (List [App+ "()" (List []),App "Ident" (List [App "()" (List []),Concat (List+ [String "x",ShowInt FieldIndex])])]))])])],App "UnGuardedRhs" (+ List [App "()" (List []),Fold (App "InfixApp" (List [App "()" (+ List []),Tail,App "QVarOp" (List [App "()" (List []),App "UnQual"+ (List [App "()" (List []),App "Symbol" (List [App "()" (List []),+ String "|+"])])]),Head])) (Concat (List [Reverse (MapField (App+ "Var" (List [App "()" (List []),App "UnQual" (List [App "()" (List+ []),App "Ident" (List [App "()" (List []),Concat (List [String "x"+ ,ShowInt FieldIndex])])])]))),List [App "App" (List [App "()" (+ List []),App "Var" (List [App "()" (List []),App "UnQual" (List [+ App "()" (List []),App "Ident" (List [App "()" (List []),String+ "plate"])])]),App "Con" (List [App "()" (List []),App "UnQual" (+ List [App "()" (List []),App "Ident" (List [App "()" (List []),+ CtorName])])])])]]))]),App "Nothing" (List [])]))])])]])])]+-- GENERATED STOP++-- InstDecl SrcLoc (Maybe Overlap) [TyVarBind] Context QName [Type] [InstDecl]+-- InstDecl l (Maybe (Overlap l)) (InstRule l) (Maybe [InstDecl l])+custom x [InstDecl () x2 (IParen () rule) mbDecl] = custom x [InstDecl () x2 rule mbDecl]+custom (_,d) [InstDecl () x2 (IRule () x3 _ ihead) x7] = [InstDecl () x2 (IRule () x3 x4 iheadOut) x7]+ where+ (_x6, x5) = collect [] ihead+ vars = dataDeclVars d+ dd = (if null vars then id else TyParen ()) $ tyApps (tyCon $ dataDeclName d) (map tyVar vars)+ x4 = Just $ CxTuple () $+ concatMap f vars ++ [ClassA () (qname x) [tyVar "to"] | x <- ["Typeable","Uniplate"]]+ x6 = [dd, tyVar "to"]+ iheadOut = foldr (flip (IHApp ())) (IHCon () x5) x6+ f v = [ClassA () (qname "Typeable") [tyVar v], ClassA () (qname "PlateAll") [tyVar v, tyVar "to"]]+ collect acc (IHCon () qname) = (acc, qname)+ collect acc (IHInfix () arg qname) = (arg:acc, qname)+ collect acc (IHParen () ih) = collect acc ih+ collect acc (IHApp () ih arg) = collect (arg:acc) ih
+ src/Data/Derive/Update.hs view
@@ -0,0 +1,47 @@+{-|+ A Pseudo derivation. For every label, creates a function+ foo_u and foo_s which updates and sets the label respectively,+ e.g. 'foo_u (+1) bar' or 'foo_s 10 baz'+-}+module Data.Derive.Update(makeUpdate) where++{-++test :: Computer++speed_u :: (Int -> Int) -> Computer -> Computer+speed_u f x = x{speed = f (speed x)}++speed_s :: Int -> Computer -> Computer+speed_s v x = x{speed = v}++weight_u :: (Double -> Double) -> Computer -> Computer+weight_u f x = x{weight = f (weight x)}++weight_s :: Double -> Computer -> Computer+weight_s v x = x{weight = v}++test :: Sample++-}++import Language.Haskell+import Data.Derive.Internal.Derivation+import Data.Maybe+++makeUpdate :: Derivation+makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d+++makeUpdateField :: DataDecl -> String -> [Decl ()]+makeUpdateField d field =+ [TypeSig () [name upd] (TyFun () (TyParen () (TyFun () typF typF)) typR)+ ,bind upd [pVar "f",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (App () (var "f") (Paren () $ App () (var field) (var "x")))]+ ,TypeSig () [name set] (TyFun () typF typR)+ ,bind set [pVar "v",pVar "x"] $ RecUpdate () (var "x") [FieldUpdate () (qname field) (var "v")]]+ where+ set = field ++ "_s"+ upd = field ++ "_u"+ typR = TyFun () (dataDeclType d) (dataDeclType d)+ typF = fromJust $ lookup field $ concatMap ctorDeclFields $ dataDeclCtors d
+ src/Data/DeriveDSL.hs view
@@ -0,0 +1,21 @@++module Data.DeriveDSL(DSL, deriveDSL, applyDSL, dynamicDSL) where++import Data.Derive.DSL.Derive+import Data.Derive.DSL.Apply+import Data.Derive.DSL.DSL+import Data.Derive.DSL.HSE+import Data.Derive.DSL.SYB+import Data.Maybe+++deriveDSL :: [Decl ()] -> Maybe DSL+deriveDSL = listToMaybe . derive+++applyDSL :: DSL -> DataDecl -> Either String [Decl ()]+applyDSL dsl inp = Right $ apply dsl $ toInput inp+++dynamicDSL :: DSL -> Maybe [Decl ()]+dynamicDSL = dslSYB
+ src/Data/DeriveMain.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Needed for Haddock docs++-- | Use this module to create your own derive program, supporting custom derivations.+-- As an example:+--+-- @+-- import "Data.DeriveMain" ('deriveMain')+-- import "Data.Derive.All" ('derivations')+-- import MyProject.MyDerivation (myDerivation)+-- @+--+-- @+-- main :: IO+-- main = 'deriveMain' $ [myDerivation] ++ 'derivations'+-- @+module Data.DeriveMain(deriveMain) where++import Derive.Main+import Data.Derive.All(derivations)
+ src/Data/DeriveTH.hs view
@@ -0,0 +1,44 @@+-- | The main TH driver module. It is intended that this need be the+-- only module imported by user code; it takes care of all data+-- threading issues such that all one needs to do is:+--+-- @+-- data Foo = Foo ; $( derive makeEq ''Foo )+-- @+module Data.DeriveTH(derive, derives, deriveFromDec, module Data.Derive.All) where++import Control.Monad++import Data.Derive.All+import Data.Derive.Internal.Derivation+import Language.Haskell.TH.All as TH hiding (Derivation(..),toName)+import Language.Haskell as HS+import Language.Haskell.Convert+++-- | Derive an instance of some class. @derive@ only derives instances+-- for the type of the argument.+derive :: Derivation -> TH.Name -> Q [Dec]+derive d name = do+ x <- reify name+ case x of+ TyConI dec -> deriveFromDec d dec+ _ -> error $ "Data.DeriveTH.derive: Expected a data type declaration, got:\n" ++ show x+++derives :: [Derivation] -> [TH.Name] -> Q [Dec]+derives xs ys = liftM concat $ sequence [derive x y | y <- ys, x <- xs]+++-- | Derive an instance of some class. @deriveFromDec@ only derives instances+-- for the type of the argument.+deriveFromDec :: Derivation -> Dec -> Q [Dec]+deriveFromDec d x = do+ x <- liftM normData $ expandData x+ let unsup x = error $ "Derivation of " ++ derivationName d ++ " does not yet support Template Haskell, requires info for " ++ x+ case derivationOp d (tyCon $ derivationName d) unsup $ toFullDataDecl x of+ Left y -> runIO (putStrLn $ "Warning, couldn't derive: " ++ y) >> return []+ Right v -> return $ convert v++toFullDataDecl :: Dec -> FullDataDecl+toFullDataDecl x = (ModuleName () "Todo", convert x)
+ src/Derive/Derivation.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE ViewPatterns #-}++module Derive.Derivation(wantDerive, performDerive, writeDerive) where++import System.IO+import System.IO.Unsafe+import Language.Haskell+import Control.Arrow+import Control.Monad+import Data.List+import Derive.Utils+import Derive.Flags+import Data.Derive.Internal.Derivation+import qualified Data.Map as Map+++---------------------------------------------------------------------+-- WHAT DO YOU WANT TO DERIVE++wantDerive :: [Flag] -> Module () -> Module () -> [Type ()]+wantDerive flag real mine = nub $ map fromTyParens $ wantDeriveFlag flag decls ++ wantDeriveAnnotation real mine+ where decls = filter isDataDecl $ moduleDecls mine+++wantDeriveFlag :: [Flag] -> [DataDecl] -> [Type ()]+wantDeriveFlag flags decls = [TyApp () (tyCon x) d | Derive xs <- flags, x <- xs, d <- declst]+ where declst = [tyApps (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d) | d <- decls]++wantDeriveAnnotation :: Module () -> Module () -> [Type ()]+wantDeriveAnnotation real mine = moduleDerives mine \\ moduleDerives real+++moduleDerives :: Module () -> [Type ()]+moduleDerives = concatMap f . moduleDecls+ where+ f (DataDecl _ _ _ (fromDeclHead -> (name, vars)) _ deriv) = g name vars deriv+ f (GDataDecl _ _ _ (fromDeclHead -> (name, vars)) _ _ deriv) = g name vars deriv+ f (DerivDecl _ _ _ (fromIParen -> IRule _ _ _ (fromInstHead -> (name, args)))) = [TyCon () name `tyApps` args]+ f _ = []++ g name vars deriv = [TyCon () a `tyApps` (b:bs) | IRule _ _ _ (fromInstHead -> (a,bs)) <- map fromIParen $ f deriv]+ where b = TyCon () (UnQual () name) `tyApps` map (tyVar . prettyPrint) vars+ f [Deriving _ _ xs] = xs+ f _ = []+++---------------------------------------------------------------------+-- ACTUALLY DERIVE IT++performDerive :: [Derivation] -> Module () -> [Type ()] -> [String]+performDerive derivations modu = concatMap ((:) "" . f)+ where+ grab = getDecl modu++ g = getDerivation derivations+ f ty = case d ty grab (moduleName modu, grab typ1Name) of+ Left x -> unsafePerformIO $ let res = msg x in hPutStrLn stderr res >> return ["-- " ++ res]+ Right x -> concatMap (lines . prettyPrint) x+ where+ d = derivationOp $ g clsName+ (cls,typ1:_) = fromTyApps ty+ clsName = prettyPrint cls+ typ1Name = tyRoot typ1+ msg x = "Deriving " ++ prettyPrint ty ++ ": " ++ x+++getDecl :: Module () -> (String -> Decl ())+getDecl modu = \name -> Map.findWithDefault (error $ "Can't find data type definition for: " ++ name) name mp+ where+ mp = Map.fromList $ concatMap f $ moduleDecls modu+ f x@(DataDecl _ _ _ (fromDeclHead -> (name, _)) _ _) = [(prettyPrint name, x)]+ f x@(GDataDecl _ _ _ (fromDeclHead -> (name, _)) _ _ _) = [(prettyPrint name, x)]+ f x@(TypeDecl _ (fromDeclHead -> (name, _)) _) = [(prettyPrint name, x)]+ f _ = []+++getDerivation :: [Derivation] -> String -> Derivation+getDerivation derivations = \name -> Map.findWithDefault (error $ "Don't know how to derive type class: " ++ name) name mp+ where+ mp = Map.fromList $ map (derivationName &&& id) derivations+++---------------------------------------------------------------------+-- WRITE IT BACK++writeDerive :: FilePath -> ModuleName () -> [Flag] -> [String] -> IO ()+writeDerive file modu flags xs = do+ -- force the output first, ensure that we don't crash half way through+ () <- length (concat xs) `seq` return ()++ let append = Append `elem` flags+ let output = [x | Output x <- flags]++ let ans = take 1 ["module " ++ x ++ " where" | Modu x <- reverse flags] +++ ["import " ++ if null i then prettyPrint modu else i | Import i <- flags] +++ xs++ when append $ do+ src <- readFile' file+ writeGenerated file ans++ forM output $ \o -> writeFile o $ unlines ans+ when (not append && null output) $ putStr $ unlines ans
+ src/Derive/Flags.hs view
@@ -0,0 +1,65 @@++module Derive.Flags(Flag(..), getFlags, addFlags, flagInfo) where++import System.Environment+import System.Console.GetOpt+import System.Directory+import Language.Haskell+import System.Exit+import System.IO+import Data.Maybe+++data Flag = Version | Help | Output String | Import String | Modu String+ | Append | Derive [String] | NoOpts | Preprocessor | Test | Generate+ deriving (Eq, Show)+++options :: [OptDescr Flag]+options =+ [Option "v" ["version"] (NoArg Version) "show version number"+ ,Option "h?" ["help"] (NoArg Help) "show help message"+ ,Option "o" ["output"] (ReqArg Output "FILE") "output FILE"+ ,Option "i" ["import"] (OptArg (Import . fromMaybe "") "MODULE") "add an import statement"+ ,Option "m" ["module"] (ReqArg Modu "MODULE") "add a module MODULE where statement"+ ,Option "a" ["append"] (NoArg Append) "append the result to the file"+ ,Option "d" ["derive"] (ReqArg splt "DERIVES") "things to derive for all types"+ ,Option "n" ["no-opts"] (NoArg NoOpts) "ignore the file options"+ ,Option "F" ["preprocessor"] (NoArg Preprocessor) "operate as a GHC preprocessor with -pgmF"+ ,Option "" ["test"] (NoArg Test) "run the test suite"+ ,Option "" ["generate"] (NoArg Generate) "perform code generation"+ ]+ where splt = Derive . words . map (\x -> if x == ',' then ' ' else x)+++flagInfo = usageInfo "Usage: derive [OPTION...] files..." options+++getFlags :: IO ([Flag], [String])+getFlags = do+ args <- getArgs+ case getOpt Permute options args of+ (o,n,[] ) | Version `elem` o -> putStrLn "Derive 2.5.* (C) Neil Mitchell 2006-2013" >> exitSuccess+ | Help `elem` o -> putStr flagInfo >> exitSuccess+ | Preprocessor `elem` o -> return (o,n)+ | otherwise -> do files <- mapM pickFile n; return (o, files)+ (_,_,errs) -> hPutStr stderr (concat errs ++ flagInfo) >> exitFailure+ where+ exitSuccess = exitWith ExitSuccess+++pickFile :: FilePath -> IO FilePath+pickFile orig = f [orig, orig ++ ".hs", orig ++ ".lhs"]+ where+ f [] = error $ "File not found: " ++ orig+ f (x:xs) = do+ b <- doesFileExist x+ if b then return x else f xs+++addFlags :: [Flag] -> (SrcLoc, [String]) -> [Flag]+addFlags flags (sl,xs)+ | NoOpts `elem` flags = flags+ | errs /= [] = error $ prettyPrint sl ++ "\n" ++ concat errs+ | otherwise = flags ++ a+ where (a,_,errs) = getOpt Permute options xs
+ src/Derive/Generate.hs view
@@ -0,0 +1,115 @@++module Derive.Generate(generate) where++import Language.Haskell.Exts+import Data.DeriveDSL+import Derive.Utils+import Control.Monad+import Data.Maybe+import System.FilePath+import System.Directory+import Data.Char+import Data.List+++evil = words "TTypeable Uniplate"++-- generate extra information for each derivation+generate :: IO ()+generate = do+ xs <- getDirectoryContents "src/Data/Derive"+ xs <- return $ sort [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]+ lis <- mapM generateFile $ map ("src/Data/Derive" </>) xs+ let names = map dropExtension xs+ n = maximum $ map length names+ writeGenerated "src/Data/Derive/All.hs" $+ ["import Data.Derive." ++ x ++ replicate (4 + n - length x) ' ' ++ "as D" | x <- names] +++ ["derivations :: [Derivation]"+ ,"derivations = [make" ++ concat (intersperse ",make" names) ++ "]"]+ writeGenerated "README.md" $ ["-->",""] ++ lis ++ ["","<!--"]+ writeGenerated "derive.cabal" $ map (" Data.Derive."++) names+++-- return the Documentation string+generateFile :: FilePath -> IO String+generateFile file = do+ let name = takeBaseName file+ putStrLn $ "Generating " ++ name+ src <- readSrc file+ when (isJust $ srcExample src) $ do+ let dsl = fromMaybe (error $ "Couldn't derive example for " ++ name) $+ deriveDSL $ fromJust $ srcExample src+ writeGenerated file $+ [""+ ,"import Data.Derive.DSL.DSL"+ ,"import Data.Derive.Internal.Derivation"+ ,""+ ,"make" ++ name ++ " :: Derivation"+ ] ++ (if srcCustom src then+ ["make" ++ name ++ " = derivationCustomDSL " ++ show name ++ " custom $"]+ else+ ["make" ++ name ++ " = derivationDSL " ++ show name ++ " dsl" ++ name+ ,""+ ,"dsl" ++ name ++ " ="+ ]) +++ map (replicate 4 ' ' ++) (wrap 66 $ show dsl)++ let inst = dynamicDSL dsl+ instFile = takeDirectory file </> "Instance" </> name <.> "hs"+ b <- doesFileExist instFile++ if not (srcCustom src) && isJust inst then do+ writeGenerated instFile $+ ["{-# LANGUAGE FlexibleInstances, UndecidableInstances, ScopedTypeVariables #-}"] +++ ["","module Data.Derive.Instance." ++ name ++ " where",""] +++ (map prettyPrint $ srcImportStd src) +++ ["import Data.Derive.Internal.Instance",""] +++ (map prettyPrint $ fromJust inst) ++ [""]+ else when b $+ error $ "Previously generated dynamic instance can not be regenerated, " ++ name++ let imp = listToMaybe $ srcImport src+ return $+ "* **[" ++ name ++ "](" ++ instUrl name imp ++ ")**" +++ concat [" - from the library [" ++ pkg ++ "](" ++ pkgUrl pkg ++ ")" | Just imp <- [imp], let pkg = fromMaybe "base" $ importPkg imp]++pkgUrl x = "http://hackage.haskell.org/package/" ++ x++instUrl name Nothing = "http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-" ++ name ++ ".html"+instUrl name (Just x) = "http://hackage.haskell.org/packages/archive/" ++ pkgName ++ "/" ++ pkgVersion ++ "/doc/html/" ++ modu ++ ".html#t%3A" ++ nam+ where+ (a,b) = break (== '-') $ fromMaybe "base" $ importPkg x+ pkgName = a+ pkgVersion = if null b then "latest" else tail b+ modu = reps '.' '-' $ prettyPrint $ importModule x+ nam = case importSpecs x of Just (ImportSpecList _ 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)
+ src/Derive/Main.hs view
@@ -0,0 +1,67 @@++module Derive.Main(deriveMain) where++import Language.Haskell+import Data.Derive.All(Derivation)+import Derive.Derivation+import Derive.Generate+import Derive.Test+import Derive.Flags+import Data.List+import System.Directory+++deriveMain :: [Derivation] -> IO ()+deriveMain derivations = do+ (flags,files) <- getFlags+ if Test `elem` flags then+ test+ else if Generate `elem` flags then+ generate+ else if Preprocessor `elem` flags then+ (if length files /= 3 then+ error $ "Expected to be invoked as a GHC preprocessor with 3 files, but got " ++ show (length files)+ else do+ copyFile (files !! 1) (files !! 2)+ mainFile derivations (Append:flags) (files !! 2)+ )+ else if null files then+ putStr $ "No files specified\n" ++ flagInfo+ else+ mapM_ (mainFile derivations flags) files+++mainFile :: [Derivation] -> [Flag] -> FilePath -> IO ()+mainFile derivations flags file = do+ src <- readFile file+ src <- return $ unlines $ filter (not . isPrefixOf "#") $ lines src+ let parse = fromParseResult . parseFileContentsWithMode defaultParseMode{parseFilename=file,extensions=defaultExtensions}+ real = parse src+ mine = parse $ uncomment src :: Module SrcSpanInfo+ flags <- return $ foldl addFlags flags+ [(getPointLoc sl,words x) | OptionsPragma sl (Just (UnknownTool "DERIVE")) x <- modulePragmas mine]+ let blur = fmap (const ())+ let res = performDerive derivations (blur mine :: Module ()) $ wantDerive flags (blur real) (blur mine)+ writeDerive file (moduleName $ blur mine) flags res+++uncomment :: String -> String+uncomment ('{':'-':'!':xs) = ' ':' ':' ':uncomment xs+uncomment ('!':'-':'}':xs) = ' ':' ':' ':uncomment xs+uncomment (x:xs) = x:uncomment xs+uncomment [] = []+++-- Taken from HLint, update occasionally+defaultExtensions :: [Extension]+defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions++badExtensions =+ [Arrows -- steals proc+ ,TransformListComp -- steals the group keyword+ ,XmlSyntax, RegularPatterns -- steals a-b+ ,UnboxedTuples -- breaks (#) lens operator+ ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+ ,DoRec, RecursiveDo -- breaks rec+ ,TypeApplications -- HSE fails on @ patterns+ ]
+ src/Derive/Test.hs view
@@ -0,0 +1,100 @@++module Derive.Test(test) where++import Derive.Utils+import Data.Derive.DSL.HSE+import Control.Monad+import Data.Maybe+import Data.List+import System.FilePath+import System.Process+import System.Exit+import Control.Arrow+import Data.Derive.All+import Data.Derive.Internal.Derivation+++-- These overlap with other derivations+overlaps =+ [["BinaryDefer","EnumCyclic","LazySet","DataAbstract"]+ ,["Serialize"]]++-- REASONS:+-- UniplateDirect: Doesn't work through Template Haskell+-- Typeable cannot be separately derived in GHC 7.8+exclude = ["ArbitraryOld","UniplateDirect","Ref","Serial","Binary","Typeable"]++-- These must be first and in every set+priority = []+++listType :: Decl ()+listType = DataDecl () (DataType ()) Nothing (DHApp () (DHead () (Ident () "[]")) (UnkindedVar () $ Ident () "a"))+ [QualConDecl () Nothing Nothing (ConDecl () (Ident () "[]") [])+ ,QualConDecl () Nothing Nothing (ConDecl () (Ident () "Cons")+ [TyVar () (Ident () "a")+ ,TyApp () (TyCon () (UnQual () (Ident () "List"))) (TyVar () (Ident () "a"))])]+ []+++-- test each derivation+test :: IO ()+test = do+ decls <- fmap (filter isDataDecl . moduleDecls) $ readHSE "Data/Derive/Internal/Test.hs"++ -- check the test bits+ let ts = ("[]",listType) : map (dataDeclName &&& id) decls+ mapM_ (testFile ts) derivations++ -- check the $(derive) bits+ putStrLn "Type checking examples"+ let name = "AutoGenerated_Test"+ devs <- sequence [liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]+ let lookupDev x = fromMaybe (error $ "Couldn't find derivation: " ++ x) $ find ((==) x . derivationName . fst) devs++ let sets = zip [1..] $ map (map lookupDev) $ map (priority++) $+ [d | d <- map (derivationName . fst) devs, d `notElem` (exclude ++ priority ++ concat overlaps)] : overlaps++ forM sets $ \(i,xs) -> autoTest (name++show i) decls xs+ writeFile (name++".hs") $ unlines $+ ["import " ++ name ++ show (fst i) | i <- sets] ++ ["main = putStrLn \"Type checking successful\""]+ res <- system $ "runhaskell -isrc " ++ name ++ ".hs"+ when (res /= ExitSuccess) $ error "Failed to typecheck results"+++testFile :: [(String,Decl ())] -> Derivation -> IO ()+testFile types (Derivation name op) = do+ putStrLn $ "Testing " ++ name+ src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"+ forM_ (srcTest src) $ \(typ,res) -> do+ let d = if tyRoot typ /= name then tyRoot typ else tyRoot $ head $ snd $ fromTyApps $ fromTyParen typ+ let grab x = fromMaybe (error $ "Error in tests, couldn't resolve type: " ++ x) $ lookup x types+ let Right r = op typ grab (ModuleName () "Example", grab d)+ when (not $ r `outEq` res) $+ error $ "Results don't match!\nExpected:\n" ++ showOut res ++ "\nGot:\n" ++ showOut r ++ "\n\n" ++ detailedNeq res r++detailedNeq as bs | na /= nb = "Lengths don't match, " ++ show na ++ " vs " ++ show nb+ where na = length as ; nb = length bs++detailedNeq as bs = "Mismatch on line " ++ show i ++ "\n" ++ show a ++ "\n" ++ show b+ where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)+++autoTest :: String -> [DataDecl] -> [(Derivation,Src)] -> IO ()+autoTest name ts ds =+ writeFile (name++".hs") $ unlines $+ ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses,TypeOperators,DeriveDataTypeable #-}"+ ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields -fno-warn-unused-imports #-}"+ ,"module " ++ name ++ " where"+ ,"import Prelude"+ ,"import Data.DeriveTH"+ ,"import Data.Typeable"+ ,"import Derive.TestInstances()"] +++ [prettyPrint i | (_,s) <- ds, i <- srcImportStd s] +++ [prettyPrint t ++ "\n deriving Typeable" | t <- ts2] +++ ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | (d,_) <- ds]+ where+ types = "[" ++ intercalate "," ["''" ++ dataDeclName t | t <- ts2] ++ "]"+ ts2 = filter (not . isBuiltIn) ts++isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]
+ src/Derive/Utils.hs view
@@ -0,0 +1,86 @@++module Derive.Utils where++import Data.Derive.DSL.HSE+import Data.List+import qualified Data.ByteString.Char8 as BS+import System.Directory+import System.IO+import System.FilePath+import Control.Monad+import Data.Maybe+++data Src = Src+ {srcName :: String+ ,srcImport :: [ImportDecl ()]+ ,srcExample :: Maybe [Decl ()]+ ,srcTest :: [(Type (),[Decl ()])]+ ,srcCustom :: Bool+ }++-- skip the importPkg bits+srcImportStd :: Src -> [ImportDecl ()]+srcImportStd y= [x{importPkg=Nothing} | x <- srcImport y]++nullSrc = Src "" [] Nothing [] False+++readHSE :: FilePath -> IO (Module ())+readHSE file = do+ src <- readFile' file+ src <- return $ takeWhile (/= "-}") $ drop 1 $ dropWhile (/= "{-") $+ dropWhile (not . isPrefixOf "module ") $ lines src++ let mode = defaultParseMode{extensions=map EnableExtension [MultiParamTypeClasses,FlexibleContexts,TemplateHaskell,PackageImports,TypeOperators]}+ return $ fmap (const ()) $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src+++data Pragma = Example Bool | Test (Type ())++asPragma :: Decl () -> Maybe Pragma+asPragma (TypeSig _ [x] t)+ | x ~= "example" = Just $ Example $ prettyPrint t == "Custom"+ | x ~= "test" = Just $ Test t+asPragma _ = Nothing+++readSrc :: FilePath -> IO Src+readSrc file = do+ modu <- readHSE file+ return $ foldl f nullSrc{srcName=takeBaseName file, srcImport=moduleImports modu}+ [ (p,xs)+ | p:real <- tails $ moduleDecls modu, Just p <- [asPragma p]+ , let xs = takeWhile (isNothing . asPragma) real ]+ where+ f src (Example x,bod) = src{srcExample = Just bod, srcCustom = x}+ f src (Test x,bod) = src{srcTest = srcTest src ++ [(x,bod)]}+++generatedStart = "-- GENERATED START"+generatedStop = "-- GENERATED STOP"++++writeGenerated :: FilePath -> [String] -> IO ()+writeGenerated file x = do+ src <- fmap lines $ readFile' file+ let pre = takeWhile (/= generatedStart) src+ post = drop 1 $ dropWhile (/= generatedStop) src+ src2 = pre ++ [generatedStart] ++ x ++ [generatedStop] ++ post+ when (src /= src2) $+ seq (length src2) $ writeBinaryFile file $ unlines src2+++readFile' :: FilePath -> IO String+readFile' file = do+ b <- doesFileExist file+ if b then fmap BS.unpack $ BS.readFile file else return []+++writeBinaryFile :: FilePath -> String -> IO ()+writeBinaryFile file x = withBinaryFile file WriteMode (`hPutStr` x)+++rep from to x = if x == from then to else x+reps from to = map (rep from to)
+ src/Language/Haskell.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE PatternGuards #-}+module Language.Haskell(module Language.Haskell, module Language.Haskell.Exts) where++import Language.Haskell.Exts hiding (var,app,binds,paren,FieldDecl)+import qualified Language.Haskell.Exts as HSE+import Data.List+import Data.Generics.Uniplate.Data+import Data.Data+import Data.Char+import Data.Maybe+import Control.Arrow+++infix 1 ?+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]) Nothing x+++tyApps x [] = x+tyApps x (y:ys) = tyApps (TyApp () x y) ys+++fromTyApps (TyTuple _ _ xs) = (tyCon $ "(" ++ replicate (length xs - 1) ',' ++ ")", xs)+fromTyApps (TyApp _ x y) = let (a,b) = fromTyApps x in (a, b ++ [y])+fromTyApps (TyList _ x) = (TyCon () $ Special () $ ListCon (), [x])+fromTyApps x = (x, [])++fromTyTuple (TyTuple _ _ xs) = xs+fromTyTuple x = [x]++fromTyParen (TyParen () x) = fromTyParen x+fromTyParen x = x++fromTyParens = transform fromTyParen++tyRoot = prettyPrint . fst . fromTyApps . fromTyParen++isTyFun :: Type () -> Bool+isTyFun TyFun{} = True+isTyFun _ = False++isTyParen TyParen{} = True ; isTyParen _ = False++fromTyList (TyList _ x) = Just x+fromTyList (TyApp _ (TyCon _ (Special _ ListCon{})) x) = Just x+fromTyList x = Nothing+++x ~= y = prettyPrint x == y+++appP x@App{} y = App () x y+appP x y = App () (paren x) (paren y)+++simplify :: Data a => a -> a+simplify = transformBi fDecl . transformBi fMatch . transformBi fPat . transformBi fTyp . transformBi fExp+ where+ fExp :: Exp () -> Exp ()+ fExp (App _ op (List _ xs))+ | op ~= "length" = Lit () $ Int () (fromIntegral $ length xs) (show $ length xs)+ | op ~= "head" = head xs+ | op ~= "null" = con $ show $ null xs+ fExp (InfixApp _ (Lit _ (Int _ i _)) op (Lit _ (Int _ j _)))+ | op ~= "-" = Lit () $ Int () (i - j) (show $ i-j)+ | op ~= "+" = Lit () $ Int () (i + j) (show $ i+j)+ | op ~= ">" = Con () $ UnQual () $ Ident () $ show $ i > j+ fExp (InfixApp _ x op y)+ | op ~= "`const`" = x+ | op ~= "&&" && y ~= "True" = x+ | x ~= "id" && op ~= "." = y+ | y ~= "id" && op ~= "." = x+ fExp (InfixApp _ (Lit _ (String _ x _)) op (Lit _ (String _ y _))) | op ~= "++" = Lit () $ String () (x ++ y) (show $ x ++ y)+ fExp (App _ (App _ (App _ flp f) x) y) | flp ~= "flip" = fExp $ appP (fExp $ appP f y) x+ fExp (App _ (Paren _ x@App{}) y) = fExp $ App () x y+ fExp (App _ (Paren _ (InfixApp _ x op y)) z) | op ~= "." = fExp $ appP x $ fExp $ appP y z+ fExp (App _ op x) | op ~= "id" = x+ fExp (App _ (App _ flp con) x) | flp ~= "flip" && con ~= "const" = var "id"+ fExp (App _ (App _ con x) y) | con ~= "const" = x+ fExp (App _ choose (Tuple _ _ [x@(ExpTypeSig _ y _),z])) | choose ~= "choose" && y == z = fExp $ App () (var "return") x+ fExp (App _ op x) | op ~= "id" = x+ fExp (InfixApp _ (App _ when true) dot res)+ | when ~= "when" && true ~= "True" = res+ fExp (InfixApp _ x y z) | y ~= "++" && z ~= "[]" = x+ fExp (App _ (LeftSection _ x op) y) = fExp $ InfixApp () x op (paren y)+ fExp (Paren _ x) | isAtom x = x+ fExp (Do _ [Qualifier _ x]) = x+ fExp (Do _ (Qualifier _ (App _ ret unit):xs)) | ret ~= "return" && unit ~= "()" = fExp $ Do () xs+ fExp (Do _ (Generator _ (PVar _ x) (App _ ret y):xs)) | ret ~= "return" && once x2 xs = simplify $ Do () $ subst x2 y xs+ where x2 = Var () $ UnQual () x+ fExp (Case _ (ExpTypeSig _ x@Lit{} _) alts) = fExp $ Case () x alts+ fExp (Case _ (Lit _ x) alts) | good:_ <- good = good+ where good = [z | Alt _ (PLit _ Signless{} y) (UnGuardedRhs _ z) Nothing <- alts, y == x]+ fExp (If _ x t f)+ | x ~= "True" = t+ | x ~= "False" = f+ fExp (App _ (App _ when b) x)+ | when ~= "when" && b ~= "True" = x+ | when ~= "when" && b ~= "False" = App () (Var () $ UnQual () $ Ident () "return") (Con () $ Special () $ TupleCon () Boxed 0)+ fExp (App _ (Paren _ (Lambda _ [PVar _ x] y)) z) | once x2 y = fExp $ subst x2 z y+ where x2 = Var () $ UnQual () x+ fExp (App _ (Paren _ (Lambda _ [PWildCard _] x)) _) = x+ fExp (Lambda s ps x) = Lambda s (minPat x ps) x+ fExp (Con _ x) = Con () $ rename x+ fExp x = x++ fTyp :: Type () -> Type ()+ fTyp (TyApp _ x y) | x ~= "[]" = TyList () y+ fTyp (TyApp _ (TyCon _ (Special _ ListCon{})) x) = TyList () x+ fTyp (TyParen _ x@TyCon{}) = x+ fTyp (TyParen _ x@TyVar{}) = x+ fTyp (TyParen _ x@TyList{}) = x+ fTyp (TyCon _ nam) = TyCon () $ rename nam+ fTyp x = x++ fPat :: Pat () -> Pat ()+ fPat (PParen _ x@(PApp _ _ [])) = x+ fPat (PParen _ (PParen _ x)) = PParen () x+ fPat (PApp _ nam xs) = case rename nam of+ Special _ (TupleCon _ Boxed _) -> PTuple () Boxed xs+ nam -> PApp () nam xs+ fPat (PParen _ (PTuple _ l xs)) = PTuple () l xs+ fPat x = x++ fMatch :: Match () -> Match ()+ fMatch (Match sl nam pat (GuardedRhss _ [GuardedRhs _ [Qualifier _ x] bod]) decls)+ | x ~= "True" = fMatch $ Match sl nam pat (UnGuardedRhs () bod) decls+ fMatch (Match sl nam [PVar _ x] (UnGuardedRhs _ (Case _ (Var _ (UnQual _ x2)) [Alt _ pat (UnGuardedRhs _ y) Nothing])) decls)+ | x == x2 = fMatch $ Match sl nam [PParen () pat] (UnGuardedRhs () y) decls+ fMatch o@(Match a b c d bind) = fBinds (Match a b (minPat o c) d) bind++ fDecl :: Decl () -> Decl ()+ fDecl (PatBind a b c bind) = fBinds (PatBind a b c) bind+ fDecl (FunBind _ xs) = FunBind () $ filter (not . isGuardFalse) xs+ fDecl x = x++ fBinds context Nothing = context Nothing+ fBinds context (Just (BDecls _ bind)) | inline /= [] =+ simplify $ subst (Var () $ UnQual () from) to $ context $+ let xs = take i bind ++ drop (i+1) bind in if null xs then Nothing else Just $ BDecls () xs+ where+ f (PatBind _ (PVar _ x) (UnGuardedRhs _ bod) Nothing) = [(x,bod)]+ f (FunBind _ [Match _ x [PVar _ v] (UnGuardedRhs _ (Paren _ (App _ bod (Var _ v2)))) Nothing])+ | UnQual () v == v2 = [(x,bod)]+ f (FunBind _ [Match sl x pat (UnGuardedRhs _ bod) Nothing]) = [(x,Paren () $ Lambda sl pat bod)]+ f _ = []++ (i,from,to) = head inline+ inline = [(i, x, bod)+ | (i,b) <- zip [0..] bind, (x,bod) <- f b+ , isAtom bod || once (Var () $ UnQual () x) (context $ Just $ BDecls () bind)]+ fBinds a y = a y++ subst from to = transformBi $ \x -> if x == from then to else x+ once x y = length (filter (== x) (universeBi y)) <= 1++ minPat o ps = transformBi f ps+ where+ known = nub [x | UnQual _ x <- universeBi o]+ f (PVar () x) | x `notElem` known = PWildCard ()+ f (PAsPat () x y) | x `notElem` known = y+ f x = x++++isGuardFalse (Match sl nam pat (GuardedRhss _ [GuardedRhs _ [Qualifier _ x] bod]) decls) = x ~= "False"+isGuardFalse _ = False+++rename (UnQual _ (Ident _ ('(':xs@(x:_))))+ | x == ',' = Special () $ TupleCon () Boxed $ length xs+ | x /= ')' = UnQual () $ Symbol () $ init xs+rename x = x+++isAtom Con{} = True+isAtom Var{} = True+isAtom Lit{} = True+isAtom Paren{} = True+isAtom _ = False+++paren x = if isAtom x then x else Paren () x++sl = SrcLoc "" 0 0++noSl mr = transformBi (const sl) mr+++isIdent (x:xs) = isAlpha x || x == '_'+title (x:xs) = toUpper x : xs++qname = UnQual () . name+var = Var () . qname+con = Con () . qname+tyVar = TyVar () . name+tyVarBind = UnkindedVar () . name+tyCon = TyCon () . qname+pVar = PVar () . name+qvop = QVarOp () . UnQual () . Symbol ()++dataDeclType :: DataDecl -> Type ()+dataDeclType d = tyApp (tyCon $ dataDeclName d) (map tyVar $ dataDeclVars d)++dataDeclFields :: DataDecl -> [String]+dataDeclFields = sort . nub . filter (not . null) . map fst . concatMap ctorDeclFields . dataDeclCtors+++-- A declaration that is either a DataDecl of GDataDecl+type DataDecl = Decl ()+type CtorDecl = Either (QualConDecl ()) (GadtDecl ())+type FieldDecl = [(String, Type ())]++type FullDataDecl = (ModuleName (), DataDecl)+++moduleName (Module _ (Just (ModuleHead _ name _ _)) _ _ _) = name+moduleDecls (Module _ _ _ _ decls) = decls+moduleImports (Module _ _ _ imps _) = imps+modulePragmas (Module _ _ pragmas _ _) = pragmas+++showDecls x = unlines $ map prettyPrint x+++tyApp x [] = x+tyApp x xs = TyApp () (tyApp x $ init xs) (last xs)+++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 () (pVar n) (UnGuardedRhs () e) Nothing+binds n xs = FunBind () [Match () (name n) p (UnGuardedRhs () e) Nothing | (p,e) <- xs]+++isDataDecl :: Decl () -> Bool+isDataDecl DataDecl{} = True+isDataDecl GDataDecl{} = True+isDataDecl _ = False++dataDeclName :: DataDecl -> String+dataDeclName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name+dataDeclName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name++fromDeclHead :: DeclHead a -> (Name a, [TyVarBind a])+fromDeclHead (DHead _ n) = (n, [])+fromDeclHead (DHInfix _ x n) = (n, [x])+fromDeclHead (DHParen _ x) = fromDeclHead x+fromDeclHead (DHApp _ dh x) = second (++[x]) $ fromDeclHead dh++fromIParen :: InstRule a -> InstRule a+fromIParen (IParen _ x) = fromIParen x+fromIParen x = x++fromInstHead :: InstHead a -> (QName a, [Type a])+fromInstHead (IHCon _ x) = (x, [])+fromInstHead (IHInfix _ t x) = (x, [t])+fromInstHead (IHParen _ x) = fromInstHead x+fromInstHead (IHApp l hd t) = second (++ [t]) $ fromInstHead hd+++dataDeclVars :: DataDecl -> [String]+dataDeclVars (DataDecl _ _ _ hd _ _) = map f $ snd $ fromDeclHead hd+ where f (KindedVar _ x _) = prettyPrint x+ f (UnkindedVar _ x) = prettyPrint x++dataDeclVarsStar :: DataDecl -> [String]+dataDeclVarsStar (DataDecl _ _ _ hd _ _) = mapMaybe f $ snd $ fromDeclHead hd+ where f (UnkindedVar _ x) = Just $ prettyPrint x+ f (KindedVar _ x (KindStar _)) = Just $ prettyPrint x+ f _ = Nothing++dataDeclArity :: DataDecl -> Int+dataDeclArity = length . dataDeclVars++dataDeclCtors :: DataDecl -> [CtorDecl]+dataDeclCtors (DataDecl _ _ _ _ ctors _) = map Left ctors+++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) | HSE.FieldDecl _ as b <- fields, a <- as]++ctorDeclArity :: CtorDecl -> Int+ctorDeclArity = length . ctorDeclFields++declName :: Decl () -> String+declName (DataDecl _ _ _ name _ _) = prettyPrint $ fst $ fromDeclHead name+declName (GDataDecl _ _ _ name _ _ _) = prettyPrint $ fst $ fromDeclHead name+declName (TypeDecl _ name _) = prettyPrint $ fst $ fromDeclHead name
+ src/Language/Haskell/Convert.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}++module Language.Haskell.Convert(Convert, convert) where++import Language.Haskell as HS+import qualified Language.Haskell.Exts as HSE(FieldDecl(..))+import Language.Haskell.TH.Compat+import Language.Haskell.TH.Syntax as TH+import Control.Exception+import Data.Typeable+import System.IO.Unsafe+import Data.Maybe+++class (Typeable a, Typeable b, Show a, Show b) => Convert a b where+ conv :: a -> b+++convert :: forall a b . Convert a b => a -> b+convert a = unsafePerformIO $+ (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)+ where+ msg e = "Could not convert " ++ show (typeOf a) ++ " to " +++ show (typeOf (undefined :: b)) ++ "\n" ++ show a +++ "\n" ++ show e++++appT :: TH.Type -> [TH.Type] -> TH.Type+appT = foldl AppT++c mr = convert mr++instance Convert a b => Convert [a] [b] where+ conv = map c++++instance Convert TH.Dec (HS.Decl ()) where+ conv x = case x of+#if __GLASGOW_HASKELL__ >= 800+ DataD cxt n vs _ con ds -> f (DataType ()) cxt n vs con ds+ NewtypeD cxt n vs _ con ds -> f (NewType ()) cxt n vs [con] ds+ where+ f :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl ()+ f t cxt n vs con _ = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) []+#else+ DataD cxt n vs con ds -> f (DataType ()) cxt n vs con ds+ NewtypeD cxt n vs con ds -> f (NewType ()) cxt n vs [con] ds+ where+ f :: DataOrNew () -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl ()+ f t cxt n vs con ds = DataDecl () t (Just $ c cxt) (dh (c n) (c vs)) (c con) []+#endif++ dh name [] = DHead () name+ dh name xs = DHApp () (dh name $ init xs) (last xs)++instance Convert TH.Cxt (HS.Context ()) where+ conv = CxTuple () . map c++instance Convert (Maybe (HS.Context ())) TH.Cxt where+ conv Nothing = []+ conv (Just (CxSingle _ x)) = [c x]+ conv (Just (CxTuple _ xs)) = map c xs+ conv (Just (CxEmpty _)) = []++instance Convert TH.Name (HS.TyVarBind ()) where+ conv = UnkindedVar () . c++instance Convert TH.Name (HS.Name ()) where+ conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2+ where x2 = show x++instance Convert TH.Name (HS.QName ()) where+ conv x = if x2 == Ident () "[]" then Special () $ ListCon () else UnQual () x2+ where x2 = c x++instance Convert TH.Con (HS.QualConDecl ()) where+ conv (ForallC vs cxt x) = QualConDecl () (Just $ c vs) (Just $ c cxt) (c x)+ conv x = QualConDecl () Nothing Nothing (c x)++instance Convert TH.Con (HS.ConDecl ()) where+ conv (NormalC n xs) = ConDecl () (c n) (c xs)+ conv (RecC n xs) = RecDecl () (c n) [HSE.FieldDecl () [c x] $ c (y,z) | (x,y,z) <- xs]+ conv (InfixC x n y) = InfixConDecl () (c x) (c n) (c y)++instance Convert TH.StrictType (HS.Type ()) where+#if __GLASGOW_HASKELL__ >= 800+ conv (Bang SourceUnpack SourceStrict, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x+ conv (Bang SourceUnpack _, x) = TyBang () (NoStrictAnnot ()) (Unpack ()) $ c x+ conv (Bang _ SourceStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x+ conv (Bang _ _, x) = c x+#else+ conv (IsStrict, x) = TyBang () (BangedTy ()) (NoUnpack ()) $ c x+ conv (NotStrict, x) = c x+#if __GLASGOW_HASKELL__ >= 704+ conv (Unpacked, x) = TyBang () (BangedTy ()) (Unpack ()) $ c x+#endif+#endif++instance Convert TH.Type (HS.Type ()) where+ conv (ForallT xs cxt t) = TyForall () (Just $ c xs) (Just $ c cxt) (c t)+ conv (VarT x) = TyVar () $ c x+ conv (ConT x) | ',' `elem` show x = TyTuple () Boxed []+ | otherwise = TyCon () $ c x+ conv (AppT (AppT ArrowT x) y) = TyFun () (c x) (c y)+ conv (ArrowT) = TyCon () $ Special () $ FunCon ()+ conv (AppT ListT x) = TyList () $ c x+ conv (ListT) = TyCon () $ Special () $ ListCon ()+ conv (TupleT _) = TyTuple () Boxed []+ conv (AppT x y) = case c x of+ TyTuple _ b xs -> TyTuple () b $ xs ++ [c y]+ x -> TyApp () x $ c y++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 _ _ (fromIParen -> IRule _ _ cxt (fromInstHead -> (nam,typ))) ds) =+ instanceD (c cxt) (c $ tyApp (TyCon () nam) typ) [c d | InsDecl _ d <- fromMaybe [] ds]+ conv (FunBind _ ms@(HS.Match _ nam _ _ _:_)) = FunD (c nam) (c ms)+ conv (PatBind _ p bod ds) = ValD (c p) (c bod) (c ds)+ conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)+#if __GLASGOW_HASKELL__ >= 800+ -- ! certainly BROKEN because it ignores contexts+ conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =+ DataD (c ctx) (c nam) (c typ) Nothing (c cs) [] -- (c (map fst ds))+ conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =+ NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) [] -- (c (map fst ds))+#else+ conv (DataDecl _ DataType{} ctx (fromDeclHead -> (nam, typ)) cs ds) =+ DataD (c ctx) (c nam) (c typ) (c cs) []+ conv (DataDecl _ NewType{} ctx (fromDeclHead -> (nam, typ)) [con] ds) =+ NewtypeD (c ctx) (c nam) (c typ) (c con) []+#endif++instance Convert (HS.QualConDecl ()) TH.Con where+ conv (QualConDecl _ Nothing Nothing con) = c con+ conv (QualConDecl _ vs cx con) = ForallC (c $ fromMaybe [] vs) (c cx) (c con)++instance Convert (HS.ConDecl ()) TH.Con where+ conv (ConDecl _ nam typ) = NormalC (c nam) (c typ)+ conv (InfixConDecl _ l nam r) = InfixC (c l) (c nam) (c r)+ conv (RecDecl _ nam fs) = RecC (c nam) (concatMap c fs)++instance Convert (HSE.FieldDecl ()) [TH.VarStrictType] where+ conv (HSE.FieldDecl _ names ty) = [(c name, bang, t) | let (bang,t) = c ty, name <- names]++instance Convert (HS.Type ()) TH.StrictType where+#if __GLASGOW_HASKELL__ >= 800+ conv (TyBang _ BangedTy{} _ t) = (Bang NoSourceUnpackedness SourceStrict, c t)+#else+ conv (TyBang _ BangedTy{} _ t) = (IsStrict, c t)+#if __GLASGOW_HASKELL__ >= 704+ conv (TyBang _ _ Unpack{} t) = (Unpacked, c t)+#else+ conv (TyBang _ _ Unpack{} t) = (IsStrict, c t)+#endif+#endif+#if __GLASGOW_HASKELL__ >= 800+ conv t = (Bang NoSourceUnpackedness NoSourceStrictness, c t)+#else+ conv t = (NotStrict, c t)+#endif++instance Convert ([HS.Name ()],HS.Type ()) [TH.VarStrictType] where+ conv (names,bt) = [(c name,s,t) | name <- names]+ where (s,t) = c bt++instance Convert (HS.Asst ()) TH.Type where+ conv (InfixA _ x y z) = c $ ClassA () y [x,z]+ conv (ClassA _ x y) = appT (ConT $ c x) (c y)++instance Convert (HS.Type ()) TH.Type where+ conv (TyCon _ (Special _ ListCon{})) = ListT+ conv (TyCon _ (Special _ UnitCon{})) = TupleT 0+ conv (TyParen _ x) = c x+ conv (TyForall _ x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)+ conv (TyVar _ x) = VarT $ c x+ conv (TyCon _ x) = if x ~= "[]" then error "here" else ConT $ c x+ conv (TyFun _ x y) = AppT (AppT ArrowT (c x)) (c y)+ conv (TyList _ x) = AppT ListT (c x)+ conv (TyTuple _ _ x) = appT (TupleT (length x)) (c x)+ conv (TyApp _ x y) = AppT (c x) (c y)++instance Convert (HS.Name ()) TH.Name where+ conv = mkName . filter (`notElem` "()") . prettyPrint++instance Convert (HS.Match ()) TH.Clause where+ conv (HS.Match _ _ ps bod ds) = Clause (c ps) (c bod) (c ds)++instance Convert (HS.Rhs ()) TH.Body where+ conv (UnGuardedRhs _ x) = NormalB (c x)+ conv (GuardedRhss _ x) = GuardedB (c x)++instance Convert (HS.Exp ()) TH.Exp where+ conv (Con _ (Special _ UnitCon{})) = TupE []+ conv (Var _ x) = VarE (c x)+ conv (Con _ x) = ConE (c x)+ conv (Lit _ x) = LitE (c x)+ conv (App _ x y) = AppE (c x) (c y)+ conv (Paren _ x) = c x+ conv (InfixApp _ x y z) = InfixE (Just $ c x) (c y) (Just $ c z)+ conv (LeftSection _ x y) = InfixE (Just $ c x) (c y) Nothing+ conv (RightSection _ y z) = InfixE Nothing (c y) (Just $ c z)+ conv (Lambda _ x y) = LamE (c x) (c y)+ conv (Tuple _ _ x) = TupE (c x)+ conv (If _ x y z) = CondE (c x) (c y) (c z)+ conv (Let _ x y) = LetE (c x) (c y)+ conv (Case _ x y) = CaseE (c x) (c y)+ conv (Do _ x) = DoE (c x)+ conv (EnumFrom _ x) = ArithSeqE $ FromR (c x)+ conv (EnumFromTo _ x y) = ArithSeqE $ FromToR (c x) (c y)+ conv (EnumFromThen _ x y) = ArithSeqE $ FromThenR (c x) (c y)+ conv (EnumFromThenTo _ x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)+ conv (List _ x) = ListE (c x)+ conv (ExpTypeSig _ x y) = SigE (c x) (c y)+ conv (RecConstr _ x y) = RecConE (c x) (c y)+ conv (RecUpdate _ x y) = RecUpdE (c x) (c y)+ -- Work around bug 3395, convert to do notation instead+ conv (ListComp _ x y) = CompE $ c $ y ++ [QualStmt () $ Qualifier () x]++instance Convert (HS.GuardedRhs ()) (TH.Guard, TH.Exp) where+ conv (GuardedRhs _ g x) = (conv g, conv x)++instance Convert [HS.Stmt ()] TH.Guard where+ conv xs = PatG $ map conv xs++instance Convert (HS.Binds ()) [TH.Dec] where+ conv (BDecls _ x) = c x++instance Convert (Maybe (HS.Binds ())) [TH.Dec] where+ conv Nothing = []+ conv (Just x) = c x++instance Convert (HS.Pat ()) TH.Pat where+ conv (PParen _ x) = c x+ conv (PLit _ Signless{} x) = LitP (c x)+ conv (PTuple _ _ x) = TupP (c x)+ conv (PApp _ x y) = ConP (c x) (c y)+ conv (PVar _ x) = VarP (c x)+ conv (PInfixApp _ x y z) = InfixP (c x) (c y) (c z)+ conv (PIrrPat _ x) = TildeP (c x)+ conv (PAsPat _ x y) = AsP (c x) (c y)+ conv (PWildCard{}) = WildP+ conv (PRec _ x y) = RecP (c x) (c y)+ conv (PList _ x) = ListP (c x)+ conv (PatTypeSig _ x y) = SigP (c x) (c y)++instance Convert (HS.Literal ()) TH.Lit where+ conv (Char _ x _) = CharL x+ conv (String _ x _) = StringL x+ conv (Int _ x _) = IntegerL x+ conv (Frac _ x _) = RationalL x+ conv (PrimInt _ x _) = IntPrimL x+ conv (PrimWord _ x _) = WordPrimL x+ conv (PrimFloat _ x _) = FloatPrimL x+ conv (PrimDouble _ x _) = DoublePrimL x++instance Convert (HS.QName ()) TH.Name where+ conv (UnQual _ x) = c x+ conv (Qual _ m x) = c (Ident () $ prettyPrint m ++ "." ++ prettyPrint x)+ conv (Special _ (TupleCon _ Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS++instance Convert (HS.PatField ()) TH.FieldPat where+ conv (PFieldPat _ name pat) = (c name, c pat)+ conv (PFieldPun _ name) = (c name, c $ PVar () $ Ident () $ prettyPrint name)+ conv (PFieldWildcard _) = error "Can't convert PFieldWildcard"++instance Convert (HS.QOp ()) TH.Exp where+ conv (QVarOp _ x) = c $ Var () x+ conv (QConOp _ x) = c $ Con () x++instance Convert (HS.Alt ()) TH.Match where+ conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)++instance Convert (HS.Stmt ()) TH.Stmt where+ conv (Generator _ x y) = BindS (c x) (c y)+ conv (LetStmt _ x) = LetS (c x)+ conv (Qualifier _ x) = NoBindS (c x)++instance Convert (HS.QualStmt ()) TH.Stmt where+ conv (QualStmt _ x) = c x++instance Convert (HS.FieldUpdate ()) TH.FieldExp where+ conv (FieldUpdate _ x y) = (c x, c y)++instance Convert (HS.TyVarBind ()) TH.Name where+ conv (UnkindedVar _ x) = c x++#if __GLASGOW_HASKELL__ >= 612+instance Convert TH.TyVarBndr (HS.TyVarBind ()) where+ conv (PlainTV x) = UnkindedVar () $ c x+ conv (KindedTV x y) = KindedVar () (c x) $ c y++#if __GLASGOW_HASKELL__ < 706+instance Convert (TH.Kind ()) HS.Kind where+ conv StarK = KindStar+ conv (ArrowK x y) = KindFn (c x) $ c y+#else+instance Convert TH.Kind (HS.Kind ()) where+ conv StarT = KindStar ()+ conv (AppT (AppT ArrowT x) y) = KindFn () (c x) (c y)+#endif++#if __GLASGOW_HASKELL__ < 709+instance Convert TH.Pred (HS.Asst ()) where+ conv (ClassP x y) = ClassA () (UnQual () $ c x) $ c y+ conv (TH.EqualP x y) = HS.EqualP () (c x) $ c y++instance Convert (HS.Asst ()) TH.Pred where+ conv (ClassA _ x y) = ClassP (c x) $ c y+ conv (HS.EqualP _ x y) = TH.EqualP (c x) $ c y+#endif++instance Convert (HS.TyVarBind ()) TH.TyVarBndr where+ conv (UnkindedVar _ x) = PlainTV $ c x+ conv (KindedVar _ x y) = KindedTV (c x) $ c y++#if __GLASGOW_HASKELL__ < 706+instance Convert (HS.Kind ()) TH.Kind where+ conv (KindStar _) = StarK+ conv (KindFn _ x y) = ArrowK (c x) $ c y+#else+instance Convert (HS.Kind ()) TH.Kind where+ conv KindStar{} = StarT+ conv (KindFn _ x y) = AppT (AppT ArrowT (c x)) (c y)+#endif+#endif
+ src/Language/Haskell/TH/All.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -w #-}++module Language.Haskell.TH.All (+ module Language.Haskell.TH.All,+ module Language.Haskell.TH.Syntax, module Language.Haskell.TH.Peephole,+ module Language.Haskell.TH.Helper,+ module Language.Haskell.TH.Data, module Language.Haskell.TH.ExpandSynonym,+ ) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Peephole+import Language.Haskell.TH.Helper+import Language.Haskell.TH.ExpandSynonym+import Language.Haskell.TH.Data++import Control.Monad++++-- | The type of ways to derive classes.+-- Should not really be in this module!+data Derivation = Derivation {+ derivationDeriver :: DataDef -> Q [Dec], -- ^ The derivation function proper+ derivationName :: String -- ^ The name of the derivation+ }+++-- create a new derivation more abstractly+derivation :: (DataDef -> [Dec]) -> String -> Derivation+derivation f = Derivation (return . f)+++derivationQ :: (DataDef -> Q [Dec]) -> String -> Derivation+derivationQ = Derivation
+ src/Language/Haskell/TH/Compat.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}++-- | Compatibility definitions to paper over differences between 6.10 and 6.12.+module Language.Haskell.TH.Compat where++import Language.Haskell.TH+++#if __GLASGOW_HASKELL__ >= 612+fromTyVar :: TyVarBndr -> Name+fromTyVar (PlainTV v) = v+fromTyVar (KindedTV v _) = v+#else+fromTyVar :: Name -> Name+fromTyVar v = v+#endif++#if __GLASGOW_HASKELL__ >= 800+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif++dataDefinitionTypeArgs :: Dec -> [Name]+#if __GLASGOW_HASKELL__ >= 802+dataDefinitionTypeArgs (DataD _ _ _ _ _ deriv_clauses) =+ deriv_clauses >>= from_deriv_clause+dataDefinitionTypeArgs (NewtypeD _ _ _ _ _ deriv_clauses) =+ deriv_clauses >>= from_deriv_clause++from_deriv_clause :: DerivClause -> [Name]+from_deriv_clause (DerivClause _ cxt) = map from_cxt cxt+#elif __GLASGOW_HASKELL__ >= 800+dataDefinitionTypeArgs (DataD _cx name _ _ _ cxt) = map from_cxt cxt+dataDefinitionTypeArgs (NewtypeD cx name _ _ _ cxt) = map from_cxt cxt+#elif __GLASGOW_HASKELL__ >= 612+dataDefinitionTypeArgs (DataD _cx name _ _ args) = args+dataDefinitionTypeArgs (NewtypeD cx name _ _ args) = args+#else+dataDefinitionTypeArgs (DataD _cx name args cons _derv) = args+dataDefinitionTypeArgs (NewtypeD cx name args con derv) = args+#endif++from_cxt :: Type -> Name+from_cxt (ConT name) = name++#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 709+typeToPred :: Type -> Pred+typeToPred (ConT v) = ClassP v []+typeToPred (AppT x y) = ClassP v (t++[y])+ where ClassP v t = typeToPred x+#else+typeToPred :: Type -> Type+typeToPred x = x+#endif
+ src/Language/Haskell/TH/Data.hs view
@@ -0,0 +1,142 @@++-- | The core module of the Data.Derive system. This module contains+-- the data types used for communication between the extractors and+-- the derivors.++{-# language CPP #-}++module Language.Haskell.TH.Data where++import Data.Char+import Data.Generics++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Compat+++-- must be one of DataD or NewtypeD+type DataDef = Dec++type CtorDef = Con+++dataName :: DataDef -> String+#if __GLASGOW_HASKELL__ >= 800+dataName (DataD _ name _ _ _ _) = unqualifiedName name+dataName (NewtypeD _ name _ _ _ _) = unqualifiedName name+#else+dataName (DataD _ name _ _ _) = unqualifiedName name+dataName (NewtypeD _ name _ _ _) = unqualifiedName name+#endif++qualifiedDataName :: DataDef -> Name+#if __GLASGOW_HASKELL__ >= 800+qualifiedDataName (DataD _ name _ _ _ _) = name+qualifiedDataName (NewtypeD _ name _ _ _ _) = name+#else+qualifiedDataName (DataD _ name _ _ _) = name+qualifiedDataName (NewtypeD _ name _ _ _) = name+#endif++dataArity :: DataDef -> Int+#if __GLASGOW_HASKELL__ >= 800+dataArity (DataD _ _ xs _ _ _) = length xs+dataArity (NewtypeD _ _ xs _ _ _) = length xs+#else+dataArity (DataD _ _ xs _ _) = length xs+dataArity (NewtypeD _ _ xs _ _) = length xs+#endif++dataArgs :: DataDef -> [Name]+dataArgs = dataDefinitionTypeArgs+++dataCtors :: DataDef -> [CtorDef]+#if __GLASGOW_HASKELL__ >= 800+dataCtors (DataD _ _ _ _ xs _) = xs+dataCtors (NewtypeD _ _ _ _ x _) = [x]+#else+dataCtors (DataD _ _ _ xs _) = xs+dataCtors (NewtypeD _ _ _ x _) = [x]+#endif+++ctorName :: CtorDef -> String+ctorName (NormalC name _ ) = unqualifiedName name+ctorName (RecC name _ ) = unqualifiedName name+ctorName (InfixC _ name _) = unqualifiedName name+ctorName (ForallC _ _ c ) = ctorName c++qualifiedCtorName :: CtorDef -> Name+qualifiedCtorName (NormalC name _ ) = name+qualifiedCtorName (RecC name _ ) = name+qualifiedCtorName (InfixC _ name _) = name+qualifiedCtorName (ForallC _ _ c ) = qualifiedCtorName c+++ctorArity :: CtorDef -> Int+ctorArity (NormalC _ xs ) = length xs+ctorArity (RecC _ xs ) = length xs+ctorArity (InfixC _ _ _ ) = 2+ctorArity (ForallC _ _ c) = ctorArity c+++ctorStrictTypes :: CtorDef -> [StrictType]+ctorStrictTypes (NormalC _ xs ) = xs+ctorStrictTypes (RecC _ xs ) = [(b,c) | (a,b,c) <- xs]+ctorStrictTypes (InfixC x _ y ) = [x,y]+ctorStrictTypes (ForallC _ _ c) = ctorStrictTypes c+++ctorTypes :: CtorDef -> [Type]+ctorTypes = map snd . ctorStrictTypes+++ctorFields :: CtorDef -> [String]+ctorFields (RecC name varStrictType) = [unqualifiedName name | (name,strict,typ) <- varStrictType]+ctorFields _ = []+++-- normalisation++-- make sure you deal with "GHC.Base.."+dropModule :: String -> String+dropModule xs = case reverse xs of+ ('.':xs) -> takeWhile (== '.') xs+ xs -> reverse $ takeWhile (/= '.') xs++-- i_123432 -> i+dropNumber :: String -> String+dropNumber xs = if all isDigit a then reverse (tail b) else xs+ where (a,b) = break (== '_') $ reverse xs+++normData :: DataDef -> DataDef+normData = everywhere (mkT normType)+ where+ normType :: Type -> Type+ normType (ConT x) | show x == "[]" = ListT+ normType x = x++unqualifiedName :: Name -> String+unqualifiedName = dropModule . show+++-- convert AppT chains back to a proper list+typeApp :: Type -> (Type, [Type])+typeApp (AppT l r) = (a, b++[r])+ where (a,b) = typeApp l+typeApp t = (t, [])++++eqConT :: String -> Type -> Bool+eqConT name (ConT x) = name == show x+eqConT _ _ = False++isTupleT :: Type -> Bool+isTupleT (TupleT _) = True+isTupleT (ConT x) = head sx == '(' && last sx == ')' &&+ all (== ',') (take (length sx - 2) (tail sx))+ where sx = nameBase x+isTupleT _ = False
+ src/Language/Haskell/TH/ExpandSynonym.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE PatternGuards #-}++-- | Expand type synonyms in data declarations.+-- +-- This is needed for some type based derivations.+module Language.Haskell.TH.ExpandSynonym (expandData) where++import Language.Haskell.TH+import Language.Haskell.TH.Compat+import Language.Haskell.TH.Data+import Data.Generics++-- | Expand type synonyms in a data declaration+expandData :: DataDef -> Q DataDef+expandData = everywhereM (mkM expandType)++expandType :: Type -> Q Type+expandType t = expandType' t []++-- Walk over a type, collecting applied arguments+expandType' :: Type -> [Type] -> Q Type+expandType' (AppT t arg) args = expandType' t (arg:args)+expandType' t@(ConT name) args = do result <- expandSyn name args+ case result of+ Just (t',args') -> everywhereM (mkM expandType) $ foldl AppT t' args'+ _ -> return $ foldl AppT t args+expandType' t args = return $ foldl AppT t args++-- Is the name a type synonym and are there enough arguments? if so, apply it+expandSyn :: Name -> [Type] -> Q (Maybe (Type, [Type]))+expandSyn name args = recover (return Nothing) $ do+ info <- reify name+ case info of+ TyConI (TySynD _ synArgs t) | length args >= length synArgs+ -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym+ where (argsInst,argsMore) = splitAt (length synArgs) args+ _ -> return Nothing+ -- `recover` return Nothing++-- Substitute names for types in a type+substitute :: [Name] -> [Type] -> Type -> Type+substitute ns ts = subst (zip ns ts)+ where subst s (ForallT ns ctx t) = ForallT ns ctx (subst (filter ((`notElem` (map fromTyVar ns)) . fst) s) t)+ subst s (VarT n)+ | Just t' <- lookup n s = t'+ subst s (AppT a b) = AppT (subst s a) (subst s b)+ subst _ t = t
+ src/Language/Haskell/TH/Helper.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+++-- | These small short-named functions are intended to make the+-- construction of abstranct syntax trees less tedious.+module Language.Haskell.TH.Helper where++import Data.Char++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Data+import Language.Haskell.TH.Compat++++-- * Special folds for the guessing+++applyWith, foldl1With, foldr1With :: Exp -> [Exp] -> Exp+applyWith join xs = foldl AppE join xs+foldl1With join xs = foldr1 (\y x -> AppE (AppE join y) x) xs+foldr1With join xs = foldr1 (\y x -> AppE (AppE join x) y) xs++++-- * Syntax elements+--++-- | A simple clause, without where or guards.+sclause :: [Pat] -> Exp -> Clause+sclause pats body = Clause pats (NormalB body) []++-- | A default clause with N arguments.+defclause :: Int -> Exp -> Clause+defclause num = sclause (replicate num WildP)++-- | A simple Val clause+sval :: Pat -> Exp -> Dec+sval pat body = ValD pat (NormalB body) []+++case' :: Exp -> [(Pat, Exp)] -> Exp+case' exp alts = CaseE exp [ Match x (NormalB y) [] | (x,y) <- alts ]++(->:) :: String -> Exp -> Exp+(->:) nm bdy = LamE [vr nm] bdy++-- | We provide 3 standard instance constructors+-- instance_default requires C for each free type variable+-- instance_none requires no context+-- instance_context requires a given context+instance_none :: String -> DataDef -> [Dec] -> Dec+instance_none = instance_context []++instance_default :: String -> DataDef -> [Dec] -> Dec+instance_default n = instance_context [n] n++instance_context :: [String] -> String -> DataDef -> [Dec] -> Dec+instance_context req cls dat defs = instanceD ctx hed defs+ where+ vrs = vars 't' (dataArity dat)+ hed = l1 cls (lK (dataName dat) vrs)+ ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]+++-- | Build an instance of a class for a data type, using the heuristic+-- that the type is itself required on all type arguments.+simple_instance :: String -> DataDef -> [Dec] -> [Dec]+simple_instance cls dat defs = [instance_default cls dat defs]++-- | Build an instance of a class for a data type, using the class at the given types+generic_instance :: String -> DataDef -> [Type] -> [Dec] -> [Dec]+generic_instance cls dat ctxTypes defs = [instanceD ctx hed defs]+ where+ vrs = vars 't' (dataArity dat)+ hed = l1 cls (lK (dataName dat) vrs)+ ctx = map (typeToPred . l1 cls) ctxTypes++-- | Build a type signature declaration with a string name+sigN :: String -> Type -> Dec+sigN nam ty = SigD (mkName nam) ty++-- | Build a fundecl with a string name+funN :: String -> [Clause] -> Dec+funN nam claus = FunD (mkName nam) claus++-- * Pattern vs Value abstraction++class Eq nm => NameLike nm where+ toName :: nm -> Name+instance NameLike Name where toName = id+instance NameLike String where toName = mkName++-- | The class used to overload lifting operations. To reduce code+-- duplication, we overload the wrapped constructors (and everything+-- else, but that's irrelevant) to work in patterns, expressions, and+-- types.+class Valcon a where+ -- | Build an application node, with a name for a head and a+ -- provided list of arguments.+ lK :: NameLike nm => nm -> [a] -> a+ -- | Reference a named variable.+ vr :: NameLike nm => nm -> a+ -- | Lift a TH 'Lit'+ raw_lit :: Lit -> a+ -- | Tupling+ tup :: [a] -> a+ -- | Listing+ lst :: [a] -> a+instance Valcon Exp where+ lK nm ys = let name = toName nm in case (nameBase name, ys) of+ ("[]", []) -> ConE name+ ("[]", xs) -> lst xs+ ((x:_), args) | isUpper x || x == ':' -> foldl AppE (ConE name) args+ ((x:_), [a,b]) | isOper x -> InfixE (Just a) (VarE name) (Just b)+ where isOper x = not (isAlpha x || x == '_')+ (nm, args) -> foldl AppE (VarE name) args++ vr = VarE . toName+ raw_lit = LitE+ tup = TupE+ lst = ListE+instance Valcon Pat where+ lK = ConP . toName+ vr = VarP . toName+ raw_lit = LitP+ tup = TupP+ lst = ListP+instance Valcon Type where+ lK nm = foldl AppT (if bNm == "[]" then ListT else ConT (mkName bNm))+ where bNm = nameBase (toName nm)+ vr = VarT . toName+ raw_lit = error "raw_lit @ Type"++ -- XXX work around bug in GHC < 6.10+ -- (see http://hackage.haskell.org/trac/ghc/ticket/2358 for details)+ tup [t] = t+ tup ts = foldl AppT (TupleT (length ts)) ts++ lst = error "lst @ Type"++-- | Build an application node without a given head+app :: Exp -> [Exp] -> Exp+app root args = foldl AppE root args+++-- | This class is used to overload literal construction based on the+-- type of the literal.+class LitC a where+ lit :: Valcon p => a -> p+instance LitC Integer where+ lit = raw_lit . IntegerL+instance LitC Char where+ lit = raw_lit . CharL+instance LitC a => LitC [a] where+ lit = lst . map lit+instance (LitC a, LitC b) => LitC (a,b) where+ lit (x,y) = tup [lit x, lit y]+instance (LitC a, LitC b, LitC c) => LitC (a,b,c) where+ lit (x,y,z) = tup [lit x, lit y, lit z]+instance LitC () where+ lit () = tup []+++-- * Constructor abstraction++dataVars :: DataDef -> [Type]+dataVars dat = take (dataArity dat) $ map (VarT . mkName . return) ['a'..]++-- | Common pattern: list of a familiy of variables+vars :: Valcon a => Char -> Int -> [a]+vars c n = map (vrn c) [1 .. n]++-- | Variable based on a letter + number+vrn :: Valcon a => Char -> Int -> a+vrn c n = vr (c : show n)++-- | Make a list of variables, one for each argument to a constructor+ctv :: Valcon a => CtorDef -> Char -> [a]+ctv ctor c = vars c (ctorArity ctor)++-- | Make a simple pattern to bind a constructor+ctp :: Valcon a => CtorDef -> Char -> a+ctp ctor c = lK (ctorName ctor) (ctv ctor c)++-- | Reference the constructor itself+ctc :: Valcon a => CtorDef -> a+ctc = l0 . ctorName+++-- * Lift a constructor over a fixed number of arguments.++l0 :: (NameLike nm, Valcon a) => nm -> a+l1 :: (NameLike nm, Valcon a) => nm -> a -> a+l2 :: (NameLike nm, Valcon a) => nm -> a -> a -> a+l0 s = lK s []+l1 s a = lK s [a]+l2 s a b = lK s [a,b]++-- * Pre-lifted versions of common operations+true, false, nil :: Valcon a => a+hNil', hZero' :: Type+true = l0 "True"+false = l0 "False"+nil = l0 "[]"+unit = lit ()+hNil' = l0 "HNil"+hZero' = l0 "HZero"+id' = l0 "id"++cons :: Valcon a => a -> a -> a+cons = l2 ":"++box :: Valcon a => a -> a+return', const' :: Exp -> Exp+hSucc' :: Type -> Type+box x = cons x nil+return' = l1 "return"+const' = l1 "const"+hSucc' = l1 "HSucc"++(==:), (&&:), (++:), (>>=:), (>>:), (.:), ap', (>:) :: Exp -> Exp -> Exp+hCons' :: Type -> Type -> Type+(==:) = l2 "=="+(&&:) = l2 "&&"+(++:) = l2 "++"+(>>=:) = l2 ">>="+(>>:) = l2 ">>"+(.:) = l2 "."+(>:) = l2 ">"+ap' = l2 "ap"+hCons' = l2 "HCons"++-- | Build a chain of expressions, with an appropriate terminal+-- sequence__ does not require a unit at the end (all others are optimised automatically)+(&&::), (++::), (>>::), sequence__, (.::) :: [Exp] -> Exp+(&&::) = foldr (&&:) true+(++::) = foldr (++:) nil+(>>::) = foldr (>>:) (return' unit)+(.::) = foldr (.:) id'++sequence__ [] = return' unit+sequence__ xs = foldr1 (>>:) xs+++-- | K-way liftM+liftmk :: Exp -> [Exp] -> Exp+liftmk hd args = foldl ap' (return' hd) args
+ src/Language/Haskell/TH/Peephole.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE PatternGuards #-}++{-# OPTIONS_GHC -Wwarn #-}+{-+Otherwise I get:++src/Language/Haskell/TH/Peephole.hs:64:1: warning:+ Pattern match checker exceeded (2000000) iterations in+ an equation for ‘peep’. (Use -fmax-pmcheck-iterations=n+ to set the maximun number of iterations to n)++Seriously. Your warning checker is crap. My code is fine.+Don't produce warnings about code I can't possibly fix.+Especially not by default.+-}++module Language.Haskell.TH.Peephole(peephole, replaceVar, replaceVars) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Helper+import Data.Generics+import Data.Maybe+import Data.List+import Debug.Trace++traceMode = False+++peephole :: Data a => a -> a+peephole = everywhere (mkT peep) . everywhere (mkT peepPat)++++-- find a given string, and replace it with a particular expression+-- must succeed, so crashes readily (deliberately!)+replaceVars :: [(Name,Exp)] -> Exp -> Exp+replaceVars rep orig = fExp orig+ where+ fExp x = case x of+ VarE y -> fromMaybe x $ lookup y rep+ ConE _ -> x+ LitE _ -> x+ AppE x y -> AppE (fExp x) (fExp y)+ CaseE x y -> CaseE (fExp x) (map fMatch y)+ TupE xs -> TupE (map fExp xs)+ ListE xs -> ListE (map fExp xs)+ LamE x y -> LamE x (fPat x y)+ _ | null $ map fst rep `intersect` getNames x -> x+ _ -> error $ "replaceVar: " ++ show x++ getNames x = everything (++) ([] `mkQ` f) x+ where+ f :: Name -> [Name]+ f x = [x]++ fMatch o@(Match pat (NormalB bod) []) =+ Match pat (NormalB $ fPat [pat] bod) []++ -- given these pattern have come into scope+ -- continue matching on the rest+ fPat :: [Pat] -> Exp -> Exp+ fPat pat = replaceVars (filter ((`notElem` used) . fst) rep)+ where used = concatMap usedPats pat++ usedPats x = everything (++) ([] `mkQ` f) x+ where+ f (VarP x) = [x]+ f _ = []+++replaceVar :: Name -> Exp -> Exp -> Exp+replaceVar name with = replaceVars [(name,with)]++++-- based on the rewrite combinator in Play+peep :: Exp -> Exp+peep (ListE xs)+ | not (null xs) && all (isJust . fromLitChar) xs =+ peep $ LitE $ StringL $ map (fromJust . fromLitChar) xs+ where+ fromLitChar (LitE (CharL x)) = Just x+ fromLitChar _ = Nothing++peep (AppE x y)+ | x ~= "id" = y++peep (AppE (AppE op x) y)+ | Just res <- peepBin op x y = res++peep (InfixE (Just x) op (Just y))+ | Just res <- peepBin op x y = res++peep (LamE [] x) = x++peep (LamE [VarP x] (VarE y))+ | x == y = l0 "id"++peep (DoE [NoBindS x]) = x++peep x@(ConE _)+ | x ~= "[]" = ListE []++peep (AppE (AppE cons x) nil)+ | cons ~= ":" && nil ~= "[]" = ListE [x]++peep (DoE [BindS (VarP p) (AppE ret (LitE val)),NoBindS e])+ | ret ~= "return" = peep $ replaceVar p (LitE val) e++peep (LamE [TupP [VarP x, VarP y]] (VarE z))+ | x == z = l0 "fst"+ | y == z = l0 "snd"++peep (AppE (LamE (VarP x:xs) y) z)+ | simple z+ = peep $ LamE xs (replaceVar x z y)++peep (AppE (AppE bind (AppE ret x)) y)+ | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x++peep (InfixE (Just (AppE ret x)) bind (Just y))+ | bind ~= ">>=" && ret ~= "return" = peep $ AppE y x++peep (InfixE (Just (AppE pure x)) ap y)+ | ap ~= "<*>" && pure ~= "pure" = peep $ InfixE (Just x) (l0 "<$>") y++peep (InfixE (Just x) fmap (Just (AppE pure y)))+ | fmap ~= "<$>" && pure ~= "pure" = peep $ AppE pure (peep $ AppE x y)++peep (AppE append (ListE [x]))+ | append ~= "++" = peep $ AppE (l0 ":") x++peep (InfixE (Just (ListE [x])) append y)+ | append ~= "++" = peep $ InfixE (Just x) (l0 ":") y++peep (InfixE (Just x) cons (Just (ListE xs)))+ | cons ~= ":" = peep $ ListE (x:xs)++peep (AppE (AppE (AppE comp f) g) x)+ | comp ~= "." = peep $ AppE f (peep $ AppE g x)+peep (AppE (InfixE (Just f) comp (Just g)) x)+ | comp ~= "." = peep $ AppE f (peep $ AppE g x)++peep (AppE (AppE (AppE flip f) x) y)+ | flip ~= "flip" = peep $ AppE (AppE f y) x++peep (AppE (InfixE (Just x) op Nothing) y) = peep $ InfixE (Just x) op (Just y)+peep (AppE (InfixE Nothing op (Just y)) x) = peep $ InfixE (Just x) op (Just y)++peep (AppE f (LamE x (ListE [y])))+ | f ~= "concatMap" = peep $ AppE (l0 "map") (peep $ LamE x y)++peep (AppE f (ListE xs))+ | f ~= "head" && not (null xs) = head xs+ | f ~= "reverse" = ListE $ reverse xs++peep (AppE f (TupE [x,y]))+ | f ~= "choose" && x == y = peep $ AppE (VarE (mkName "return")) x++peep (AppE (AppE sq o@(AppE rnf x)) (TupE []))+ | sq ~= "seq" && rnf ~= "rnf" = o++peep (CaseE (LitE x) (Match (LitP y) (NormalB z) [] : _))+ | x == y = z++peep (AppE len (ListE xs))+ | len ~= "length" = LitE $ IntegerL $ toInteger $ length xs++peep (TupE [x]) = x++peep (AppE (LamE [pat] x) e) = CaseE e [Match pat (NormalB x) []]++peep (AppE (CaseE e [Match p (NormalB x) []]) y)+ = CaseE e [Match p (NormalB $ peep $ AppE x y) []]++-- allow easy flip to tracing mode+peep x | traceMode = trace (show x) x+peep x = x+++peepPat :: Pat -> Pat+peepPat (ListP xs)+ | all (\x -> case x of LitP (CharL _) -> True+ _ -> False) xs =+ LitP $ StringL $ map (\(LitP (CharL x)) -> x) xs++peepPat x = x++peepBin :: Exp -> Exp -> Exp -> Maybe Exp+peepBin op x y+ | op ~= "." && x ~= "id" = Just y+ | op ~= "." && y ~= "id" = Just x+ | op ~= "&&" && y ~= "True" = Just x+ | op ~= "const" = Just x+ | op ~= "map" && x ~= "id" = Just y+ | op ~= "++" && x ~= "[]" = Just y+ | op ~= "++" && y ~= "[]" = Just x+ | op ~= "." && y ~= "id" = Just x+ | op ~= ">>" && x ~= "return" && y == TupE [] = Just $ l0 "id"+ | op ~= "$" = Just $ peep $ AppE x y++peepBin op (LitE (StringL x)) (LitE (StringL y))+ | op ~= "++" = Just $ LitE $ StringL (x++y)++peepBin _ _ _ = Nothing+++(VarE f) ~= x = show f == x+(ConE f) ~= x = show f == x+(ListE []) ~= "[]" = True+_ ~= _ = False+++simple (VarE _) = True+simple (LitE _) = True+simple _ = False