derive 2.0.1 → 2.1.0

raw patch · 44 files changed

+802/−547 lines, 44 filesdep −packedstringdep ~haskell-src-extsdep ~uniplatePVP ok

version bump matches the API change (PVP)

Dependencies removed: packedstring

Dependency ranges changed: haskell-src-exts, uniplate

API changes (from Hackage documentation)

- Data.Derive.Data: context :: FullDataDecl -> Context

- Data.Derive.Data: splice :: FullDataDecl -> Exp -> Exp

- Data.Derive.Internal.Derivation: Derivation :: String -> (FullDataDecl -> Either String [Decl]) -> Derivation

- Data.Derive.Internal.Derivation: customContext :: (FullDataDecl -> Context) -> (FullDataDecl -> [Decl] -> [Decl])

- Data.Derive.Internal.Derivation: customSplice :: (FullDataDecl -> Exp -> Exp) -> (FullDataDecl -> [Decl] -> [Decl])

- Data.Derive.Internal.Derivation: data Derivation

- Data.Derive.Internal.Derivation: derivationCustomDSL :: String -> (FullDataDecl -> [Decl] -> [Decl]) -> DSL -> Derivation

- Data.Derive.Internal.Derivation: derivationDSL :: String -> DSL -> Derivation

- Data.Derive.Internal.Derivation: derivationName :: Derivation -> String

- Data.Derive.Internal.Derivation: derivationOp :: Derivation -> FullDataDecl -> Either String [Decl]

- Data.Derive.Internal.Instance: d_ctorArity :: Ctor -> Int

- Data.Derive.Internal.Instance: d_ctorValue :: (Data a) => Ctor -> a

- Data.Derive.Internal.Instance: d_dataCtors :: (Data a) => a -> [Ctor]

- Data.Derive.Internal.Traversal: TraveralType :: Int -> Bool -> QName -> Trav -> Trav -> (QName -> Trav -> Trav) -> (Trav -> Trav -> Trav) -> Maybe (Trav -> Trav -> Trav) -> ([Exp] -> Exp) -> (String -> [Exp] -> Exp) -> (Pat -> Exp -> Match) -> TraveralType

- Data.Derive.Internal.Traversal: data TraveralType

- Data.Derive.Internal.Traversal: deriveTraversal :: TraveralType -> DataDecl -> WithInstances Decl

- Data.Derive.Internal.Traversal: instance (Monoid w) => Applicative (Writer w)

- Data.Derive.Internal.Traversal: instance Eq RequiredInstance

- Data.Derive.Internal.Traversal: instance Ord RequiredInstance

- Data.Derive.Internal.Traversal: traversalArg :: TraveralType -> Int

- Data.Derive.Internal.Traversal: traversalCo :: TraveralType -> Bool

- Data.Derive.Internal.Traversal: traversalDerivation1 :: TraveralType -> String -> Derivation

- Data.Derive.Internal.Traversal: traversalDirect :: TraveralType -> Trav

- Data.Derive.Internal.Traversal: traversalFunc :: TraveralType -> QName -> Trav -> Trav

- Data.Derive.Internal.Traversal: traversalId :: TraveralType -> Trav

- Data.Derive.Internal.Traversal: traversalInstance :: TraveralType -> String -> DataDecl -> [WithInstances Decl] -> [Decl]

- Data.Derive.Internal.Traversal: traversalInstance1 :: TraveralType -> String -> FullDataDecl -> Either String [Decl]

- Data.Derive.Internal.Traversal: traversalName :: TraveralType -> QName

- Data.Derive.Internal.Traversal: traversalPlus :: TraveralType -> Trav -> Trav -> Trav

- Data.Derive.Internal.Traversal: traverseArrow :: TraveralType -> Maybe (Trav -> Trav -> Trav)

- Data.Derive.Internal.Traversal: traverseCtor :: TraveralType -> String -> [Exp] -> Exp

- Data.Derive.Internal.Traversal: traverseFunc :: TraveralType -> Pat -> Exp -> Match

- Data.Derive.Internal.Traversal: traverseTuple :: TraveralType -> [Exp] -> Exp

- Data.Derive.PlateTypeable: makePlateTypeable :: Derivation

+ Data.Derive.DSL.Apply: env :: Env

+ Data.Derive.DataAbstract: makeDataAbstract :: Derivation

+ Data.Derive.UniplateDirect: instance Eq Ans

+ Data.Derive.UniplateDirect: instance Show Ans

+ Data.Derive.UniplateDirect: makeUniplateDirect :: Derivation

+ Data.Derive.UniplateTypeable: makeUniplateTypeable :: Derivation

+ Language.Haskell: declName :: Decl -> String

+ Language.Haskell.Convert: instance Convert Asst Pred

+ Language.Haskell.Convert: instance Convert Kind Kind

+ Language.Haskell.Convert: instance Convert Pred Asst

+ Language.Haskell.Convert: instance Convert TyVarBind TyVarBndr

+ Language.Haskell.Convert: instance Convert TyVarBndr TyVarBind

+ Language.Haskell.TH.Compat: dataDefinitionTypeArgs :: Dec -> [Name]

+ Language.Haskell.TH.Compat: fromTyVar :: TyVarBndr -> Name

+ Language.Haskell.TH.Compat: typeToPred :: Type -> Pred

+ Language.Haskell.TH.FixedPpr: deQualLhsHead :: Dec -> Dec

+ Language.Haskell.TH.FixedPpr: deQualName :: Name -> Name

+ Language.Haskell.TH.FixedPpr: instance Ppr Kind

+ Language.Haskell.TH.FixedPpr: instance Ppr Pred

+ Language.Haskell.TH.FixedPpr: instance Ppr TyVarBndr

Files

Data/Derive/All.hs +33/−31
Data/Derive/Arbitrary.hs +1/−1
Data/Derive/ArbitraryOld.hs +1/−1
Data/Derive/BinaryDefer.hs +36/−13
Data/Derive/DSL/Apply.hs +1/−1
Data/Derive/DSL/DSL.hs +1/−1
Data/Derive/DSL/HSE.hs +1/−1
Data/Derive/Data.hs +1/−1
Data/Derive/DataAbstract.hs +62/−0
Data/Derive/EnumCyclic.hs +17/−16
Data/Derive/Fold.hs +2/−2
Data/Derive/Foldable.hs +1/−1
Data/Derive/From.hs +1/−1
Data/Derive/Functor.hs +1/−1
Data/Derive/Has.hs +1/−1
Data/Derive/Internal/Derivation.hs +13/−4
Data/Derive/Internal/Traversal.hs +2/−2
Data/Derive/Is.hs +1/−1
Data/Derive/LazySet.hs +1/−1
Data/Derive/PlateTypeable.hs +0/−58
Data/Derive/Ref.hs +1/−1
Data/Derive/Set.hs +1/−1
Data/Derive/Traversable.hs +1/−1
Data/Derive/Typeable.hs +1/−1
Data/Derive/UniplateDirect.hs +215/−0
Data/Derive/UniplateTypeable.hs +72/−0
Data/Derive/Update.hs +1/−1
Data/DeriveDSL.hs +0/−1
Data/DeriveTH.hs +3/−2
Derive/Derivation.hs +46/−325
Derive/Generate.hs +2/−2
Derive/Test.hs +38/−27
Derive/Utils.hs +3/−3
Language/Haskell.hs +54/−13
Language/Haskell/Convert.hs +28/−1
Language/Haskell/TH/Compat.hs +37/−0
Language/Haskell/TH/Data.hs +5/−3
Language/Haskell/TH/ExpandSynonym.hs +3/−2
Language/Haskell/TH/FixedPpr.hs +50/−5
Language/Haskell/TH/Helper.hs +3/−2
Language/Haskell/TH/SYB.hs +1/−1
Main.hs +31/−4
derive.cabal +14/−9
derive.htm +15/−4

Data/Derive/All.hs view

@@ -5,36 +5,38 @@ 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.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.LazySet          as D-import Data.Derive.Monoid           as D-import Data.Derive.NFData           as D-import Data.Derive.Ord              as D-import Data.Derive.PlateTypeable    as D-import Data.Derive.Read             as D-import Data.Derive.Ref              as D-import Data.Derive.Serial           as D-import Data.Derive.Set              as D-import Data.Derive.Show             as D-import Data.Derive.Traversable      as D-import Data.Derive.Typeable         as D-import Data.Derive.Update           as D+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.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.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,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeLazySet,makeMonoid,makeNFData,makeOrd,makePlateTypeable,makeRead,makeRef,makeSerial,makeSet,makeShow,makeTraversable,makeTypeable,makeUpdate]+derivations = [makeArbitrary,makeArbitraryOld,makeArities,makeBinary,makeBinaryDefer,makeBounded,makeData,makeDataAbstract,makeDefault,makeEnum,makeEnumCyclic,makeEq,makeFold,makeFoldable,makeFrom,makeFunctor,makeHas,makeIs,makeLazySet,makeMonoid,makeNFData,makeOrd,makeRead,makeRef,makeSerial,makeSet,makeShow,makeTraversable,makeTypeable,makeUniplateDirect,makeUniplateTypeable,makeUpdate] -- GENERATED STOP

Data/Derive/Arbitrary.hs view

@@ -25,7 +25,7 @@ import Data.Derive.DSL.HSE import qualified Language.Haskell as H import Data.List-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly  -- GENERATED START

Data/Derive/ArbitraryOld.hs view

@@ -1,6 +1,6 @@ module Data.Derive.ArbitraryOld where {--import "QuickCheck-1.1.0.0" Test.QuickCheck(Arbitrary)+import "QuickCheck-1.2.0.0" Test.QuickCheck(Arbitrary(..), choose,variant)  example :: Sample

Data/Derive/BinaryDefer.hs view

@@ -5,11 +5,19 @@ example :: Sample  instance BinaryDefer a => BinaryDefer (Sample a) where-    bothDefer = defer [\ ~(First) -> unit First-                      ,\ ~(Second x1 x2) -> unit Second << x1 << x2-                      ,\ ~(Third x1) -> unit Third << x1+    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 @@ -26,15 +34,30 @@     (List [App "App" (List [App "Var" (List [App "UnQual" (List [App     "Ident" (List [String "defer"])])]),App "List" (List [MapCtor (App     "Lambda" (List [List [App "PIrrPat" (List [App "PParen" (List [App-    "PApp" (List [App "UnQual" (List [App "Ident" (List [CtorName])]),-    MapField (App "PVar" (List [App "Ident" (List [Concat (List [-    String "x",ShowInt FieldIndex])])]))])])])],Fold (App "InfixApp" (-    List [Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (-    List [String "<<"])])]),Head])) (Concat (List [Reverse (MapField (+    "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])])])]))),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 []])])])])]+    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/DSL/Apply.hs view

@@ -7,7 +7,7 @@ import Data.Derive.DSL.DSL import Data.Maybe import Data.List-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly   apply :: DSL -> Input -> Out

Data/Derive/DSL/DSL.hs view

@@ -5,7 +5,7 @@ import Data.Derive.DSL.HSE import Data.List import Data.Data-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly  data DSL = App String DSL{-List-}          | Concat DSL

Data/Derive/DSL/HSE.hs view

@@ -5,7 +5,7 @@ import Language.Haskell hiding (List, App, String, Int) import qualified Language.Haskell.Exts as H import Data.Data-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly import Data.Maybe import Data.List import Data.Function

Data/Derive/Data.hs view

@@ -1,4 +1,4 @@-module Data.Derive.Data where+module Data.Derive.Data(makeData) where {- import Data.Data

+ Data/Derive/DataAbstract.hs view

@@ -0,0 +1,62 @@+{-|+    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 d = [ClassA (qname t) [tyVar x] | x <- dataDeclVars $ snd d, t <- ["Typeable","Data"]]

Data/Derive/EnumCyclic.hs view

@@ -18,7 +18,7 @@     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)+    pred a = if b == 0 then toEnum (length [First{},Second{},Third{}]) else toEnum (b-1)         where b = fromEnum a  -}@@ -85,20 +85,21 @@     "If" (List [App "InfixApp" (List [App "Var" (List [App "UnQual" (     List [App "Ident" (List [String "b"])])]),App "QVarOp" (List [App     "UnQual" (List [App "Symbol" (List [String "=="])])]),App "Lit" (-    List [App "Int" (List [Int 0])])]),Application (List [App "Var" (+    List [App "Int" (List [Int 0])])]),App "App" (List [App "Var" (     List [App "UnQual" (List [App "Ident" (List [String "toEnum"])])])-    ,App "Var" (List [App "UnQual" (List [App "Ident" (List [String-    "length"])])]),App "List" (List [MapCtor (App "RecConstr" (List [-    App "UnQual" (List [App "Ident" (List [CtorName])]),List []]))])])-    ,App "App" (List [App "Var" (List [App "UnQual" (List [App "Ident"-    (List [String "toEnum"])])]),App "Paren" (List [App "InfixApp" (-    List [App "Var" (List [App "UnQual" (List [App "Ident" (List [-    String "b"])])]),App "QVarOp" (List [App "UnQual" (List [App-    "Symbol" (List [String "-"])])]),App "Lit" (List [App "Int" (List-    [Int 1])])])])])])]),App "BDecls" (List [List [App "PatBind" (List-    [App "PVar" (List [App "Ident" (List [String "b"])]),App "Nothing"-    (List []),App "UnGuardedRhs" (List [App "App" (List [App "Var" (-    List [App "UnQual" (List [App "Ident" (List [String "fromEnum"])])-    ]),App "Var" (List [App "UnQual" (List [App "Ident" (List [String-    "a"])])])])]),App "BDecls" (List [List []])])]])])]])])])]+    ,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/Fold.hs view

@@ -39,11 +39,11 @@ import Language.Haskell import Data.Derive.Internal.Derivation import Data.List-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly   makeFold :: Derivation-makeFold = Derivation "Fold" $ \(_,d) -> Right $ simplify $ mkFold d+makeFold = derivationCustom "Fold" $ \(_,d) -> Right $ simplify $ mkFold d   mkFold :: DataDecl -> [Decl]

Data/Derive/Foldable.hs view

@@ -16,7 +16,7 @@  test :: FailList instance Foldable (FailList t1) where-    foldr _  b Zero = b+    foldr _  b Zoro = b     foldr _  b (Fail _) = b     foldr _f b (Const a1 a2) = _f a1 (Data.Foldable.foldr _f b a2)

Data/Derive/From.hs view

@@ -33,7 +33,7 @@   makeFrom :: Derivation-makeFrom = Derivation "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d+makeFrom = derivationCustom "From" $ \(_,d) -> Right $ concatMap (makeFromCtor d) $ dataDeclCtors d   makeFromCtor :: DataDecl -> CtorDecl -> [Decl]

Data/Derive/Functor.hs view

@@ -19,7 +19,7 @@  test :: FailList instance Functor (FailList t1) where-    fmap _  Zero = Zero+    fmap _  Zoro = Zoro     fmap _  (Fail a1) = Fail a1     fmap _f (Const a1 a2) = Const (_f a1) (fmap _f a2)

Data/Derive/Has.hs view

@@ -25,7 +25,7 @@   makeHas :: Derivation-makeHas = Derivation "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d+makeHas = derivationCustom "Has" $ \(_,d) -> Right $ concatMap (makeHasField d) $ dataDeclFields d   makeHasField :: DataDecl -> String -> [Decl]

Data/Derive/Internal/Derivation.hs view

@@ -1,26 +1,35 @@  module Data.Derive.Internal.Derivation(-    Derivation(..), derivationDSL, derivationCustomDSL,+    Derivation(..),+    derivationParams, derivationCustom, derivationDSL, derivationCustomDSL,     customSplice, customContext     ) where  import Data.DeriveDSL import Data.Derive.DSL.HSE-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly   data Derivation = Derivation     {derivationName :: String-    ,derivationOp :: FullDataDecl -> Either String [Decl]+    ,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 = Derivation name $+derivationCustomDSL name custom dsl = derivationCustom name $     \d -> case applyDSL dsl $ snd d of               Left x -> Left x               Right x -> Right $ simplify $ custom d x

Data/Derive/Internal/Traversal.hs view

@@ -25,7 +25,7 @@ import qualified Data.Set as S import Control.Monad.Writer import Control.Applicative-import Data.Generics.PlateData+import Data.Generics.Uniplate.DataOnly import Data.Maybe  ---------------------------------------------------------------------------------@@ -89,7 +89,7 @@  -- | Derivation for a Traversable like class with just 1 method traversalDerivation1 :: TraveralType -> String -> Derivation-traversalDerivation1 tt nm = Derivation (className $ traversalArg tt) (traversalInstance1 tt nm) +traversalDerivation1 tt nm = derivationCustom (className $ traversalArg tt) (traversalInstance1 tt nm)      where className n = nm ++ (if n > 1 then show n else "")

Data/Derive/Is.hs view

@@ -19,7 +19,7 @@   makeIs :: Derivation-makeIs = Derivation "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d+makeIs = derivationCustom "Is" $ \(_,d) -> Right $ concatMap (makeIsCtor d) $ dataDeclCtors d   makeIsCtor :: DataDecl -> CtorDecl -> [Decl]

Data/Derive/LazySet.hs view

@@ -25,7 +25,7 @@   makeLazySet :: Derivation-makeLazySet = Derivation "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d+makeLazySet = derivationCustom "LazySet" $ \(_,d) -> Right $ concatMap (makeLazySetField d) $ dataDeclFields d   makeLazySetField :: DataDecl -> String -> [Decl]

− Data/Derive/PlateTypeable.hs

@@ -1,58 +0,0 @@-module Data.Derive.PlateTypeable where-{--import "uniplate" Data.Generics.PlateTypeable(PlateAll)--example :: Sample--instance (PlateAll a (Sample a), Typeable a) => Uniplate (Sample a) where-    uniplate = uniplateAll--instance (Typeable t, Typeable a, Uniplate t, PlateAll a t) => PlateAll (Sample a) t where-    plateAll (First) = plate First-    plateAll (Second x1 x2)  = plate Second |+ x1 |+ x2-    plateAll (Third x1) = plate Third |+ x1---}--- GENERATED START--import Data.Derive.DSL.DSL-import Data.Derive.Internal.Derivation--makePlateTypeable :: Derivation-makePlateTypeable = derivationDSL "PlateTypeable" dslPlateTypeable--dslPlateTypeable =-    List [Instance ["PlateAll","Typeable"] "Uniplate" (List [App-    "InsDecl" (List [App "PatBind" (List [App "PVar" (List [App-    "Ident" (List [String "uniplate"])]),App "Nothing" (List []),App-    "UnGuardedRhs" (List [App "Var" (List [App "UnQual" (List [App-    "Ident" (List [String "uniplateAll"])])])]),App "BDecls" (List [-    List []])])])]),App "InstDecl" (List [List [App "ClassA" (List [-    App "UnQual" (List [App "Ident" (List [String "Typeable"])]),List-    [App "TyVar" (List [App "Ident" (List [String "t"])])]]),App-    "ClassA" (List [App "UnQual" (List [App "Ident" (List [String-    "Typeable"])]),List [App "TyVar" (List [App "Ident" (List [String-    "a"])])]]),App "ClassA" (List [App "UnQual" (List [App "Ident" (-    List [String "Uniplate"])]),List [App "TyVar" (List [App "Ident" (-    List [String "t"])])]]),App "ClassA" (List [App "UnQual" (List [-    App "Ident" (List [String "PlateAll"])]),List [App "TyVar" (List [-    App "Ident" (List [String "a"])]),App "TyVar" (List [App "Ident" (-    List [String "t"])])]])],App "UnQual" (List [App "Ident" (List [-    String "PlateAll"])]),List [App "TyParen" (List [App "TyApp" (List-    [App "TyCon" (List [App "UnQual" (List [App "Ident" (List [-    DataName])])]),App "TyVar" (List [App "Ident" (List [String "a"])]-    )])]),App "TyVar" (List [App "Ident" (List [String "t"])])],List [-    App "InsDecl" (List [App "FunBind" (List [MapCtor (App "Match" (-    List [App "Ident" (List [String "plateAll"]),List [App "PParen" (-    List [App "PApp" (List [App "UnQual" (List [App "Ident" (List [-    CtorName])]),MapField (App "PVar" (List [App "Ident" (List [Concat-    (List [String "x",ShowInt FieldIndex])])]))])])],App "Nothing" (-    List []),App "UnGuardedRhs" (List [Fold (App "InfixApp" (List [-    Tail,App "QVarOp" (List [App "UnQual" (List [App "Symbol" (List [-    String "|+"])])]),Head])) (Concat (List [Reverse (MapField (App-    "Var" (List [App "UnQual" (List [App "Ident" (List [Concat (List [-    String "x",ShowInt FieldIndex])])])]))),List [App "App" (List [App-    "Var" (List [App "UnQual" (List [App "Ident" (List [String "plate"-    ])])]),App "Con" (List [App "UnQual" (List [App "Ident" (List [-    CtorName])])])])]]))]),App "BDecls" (List [List []])]))])])]])]--- GENERATED STOP

Data/Derive/Ref.hs view

@@ -28,7 +28,7 @@   makeRef :: Derivation-makeRef = Derivation "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d+makeRef = derivationCustom "Ref" $ \(_,d) -> Right $ concatMap (makeRefField d) $ dataDeclFields d   makeRefField :: DataDecl -> String -> [Decl]

Data/Derive/Set.hs view

@@ -27,7 +27,7 @@   makeSet :: Derivation-makeSet = Derivation "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d+makeSet = derivationCustom "Set" $ \(_,d) -> Right $ concatMap (makeSetField d) $ dataDeclFields d   makeSetField :: DataDecl -> String -> [Decl]

Data/Derive/Traversable.hs view

@@ -17,7 +17,7 @@ import Control.Applicative(pure, (<*>))  instance Traversable (FailList t1) where-    traverse _f (Zero) = pure Nil+    traverse _f (Zoro) = pure Nil     traverse _f (Fail a1) = pure (Fail a1)     traverse _f (Const a1 a2) = (Const <$> _f a1) <*> traverse _f a2

Data/Derive/Typeable.hs view

@@ -70,7 +70,7 @@   makeTypeable :: Derivation-makeTypeable = Derivation "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x+makeTypeable = derivationCustom "Typeable" $ \(ModuleName modu,x) -> Right $ mkTypeable modu x   mkTypeable :: String -> DataDecl -> [Decl]

+ Data/Derive/UniplateDirect.hs view

@@ -0,0 +1,215 @@+{-# 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.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])+        [InsInline 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 view

@@ -0,0 +1,72 @@+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 view

@@ -31,7 +31,7 @@   makeUpdate :: Derivation-makeUpdate = Derivation "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d+makeUpdate = derivationCustom "Update" $ \(_,d) -> Right $ concatMap (makeUpdateField d) $ dataDeclFields d   makeUpdateField :: DataDecl -> String -> [Decl]

Data/DeriveDSL.hs view

@@ -7,7 +7,6 @@ import Data.Derive.DSL.HSE import Data.Derive.DSL.SYB import Data.Maybe-import Data.Generics.PlateData   deriveDSL :: [Decl] -> Maybe DSL

Data/DeriveTH.hs view

@@ -12,7 +12,7 @@  import Data.Derive.All import Data.Derive.Internal.Derivation-import Language.Haskell.TH.All as TH hiding (Derivation,toName)+import Language.Haskell.TH.All as TH hiding (Derivation(..),toName) import Language.Haskell as HS import Language.Haskell.Convert @@ -35,7 +35,8 @@ deriveFromDec :: Derivation -> Dec -> Q [Dec] deriveFromDec d x = do     x <- liftM normData $ expandData x-    case derivationOp d $ toFullDataDecl x of+    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

Derive/Derivation.hs view

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

Derive/Generate.hs view

@@ -12,13 +12,13 @@ import Data.List  -evil = words $ "PlateDirect TTypeable Uniplate"+evil = words $ "TTypeable Uniplate"  -- generate extra information for each derivation generate :: IO () generate = do     xs <- getDirectoryContents "Data/Derive"-    xs <- return [x | x <- xs, takeExtension x == ".hs", x /= "All.hs", takeBaseName x `notElem` evil]+    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

Derive/Test.hs view

@@ -18,7 +18,17 @@ import Data.Derive.Internal.Derivation  +-- These overlap with other derivations+overlap = ["BinaryDefer","EnumCyclic","LazySet","DataAbstract"] +-- 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 "[]") [])@@ -39,10 +49,19 @@      -- check the $(derive) bits     putStrLn "Type checking examples"-    let name = "AutoGenerated_Test.hs"-    srcs <- sequence [readSrc $ "Data/Derive" </> derivationName d <.> "hs" | d <- derivations]-    writeFile name $ unlines $ autoTest srcs decls derivations-    res <- system $ "runhaskell " ++ name+    let name = "AutoGenerated_Test"+    devs <- sequence [ liftM ((,) d) $ readSrc $ "Data/Derive" </> derivationName d <.> "hs"+                     | d <- derivations, derivationName d `notElem` exclude]+    +    let within xs = flip elem xs . derivationName . fst+        (pri,norm) = partition (within priority) devs+        (dev2,dev1) = partition (within overlap) norm+    +    autoTest (name++"1") decls $ pri ++ dev1+    autoTest (name++"2") decls $ pri ++ dev2+    writeFile (name++".hs") $ unlines+        ["import "++name++"1","import "++name++"2","main = putStrLn \"Type checking successful\""]+    res <- system $ "runhaskell " ++ name ++ ".hs"     when (res /= ExitSuccess) $ error "Failed to typecheck results"  @@ -51,8 +70,9 @@     putStrLn $ "Testing " ++ name     src <- readSrc $ "Data/Derive/" ++ name ++ ".hs"     forM_ (srcTest src) $ \(typ,res) -> do-        let t = fromMaybe (error $ "wanting type: " ++ typ) $ lookup typ types-        let Right r = op (ModuleName "Example", t)+        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 @@ -63,29 +83,20 @@     where (i,a,b) = head $ filter (\(i,a,b) -> a /= b) $ zip3 [1..] (noSl as) (noSl bs)  -ignore = ["ArbitraryOld","Serial","BinaryDefer","EnumCyclic","Ref","PlateTypeable","LazySet"]--autoTest :: [Src] -> [DataDecl] -> [Derivation] -> [String]-autoTest ss ts ds =-    ["{-# LANGUAGE TemplateHaskell,FlexibleInstances,MultiParamTypeClasses #-}"-    ,"{-# OPTIONS_GHC -Wall -fno-warn-missing-fields #-}"-    ,"import Data.DeriveTH"-    ,"import Derive.TestInstances()"] ++-    [prettyPrint i | s <- ss2, i <- srcImportStd s] ++-    ["main :: IO ()"-    ,"main = putStrLn \"Type checking successful\""] ++-    [prettyPrint t | t <- ts2] ++-    ["$(derives [make" ++ derivationName d ++ "] " ++ types ++ ")" | d <- ds2]+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-        ds2 = filter (flip notElem ignore . derivationName) $ order ds-        ss2 = filter (flip notElem ignore . srcName) ss  isBuiltIn x = dataDeclName x `elem` ["Bool","Either"]----order :: [Derivation] -> [Derivation]-order ds = yes ++ no-    where (yes,no) = partition (flip elem ["Eq","Typeable"] . derivationName) ds

Derive/Utils.hs view

@@ -16,7 +16,7 @@     {srcName :: String     ,srcImport :: [ImportDecl]     ,srcExample :: Maybe [Decl]-    ,srcTest :: [(String,[Decl])]+    ,srcTest :: [(Type,[Decl])]     ,srcCustom :: Bool     } @@ -37,12 +37,12 @@     return $ fromParseResult $ parseFileContentsWithMode mode $ unlines $ "module Example where":src  -data Pragma = Example Bool | Test String+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 $ prettyPrint t+    | x ~= "test" = Just $ Test t asPragma _ = Nothing

Language/Haskell.hs view

@@ -3,7 +3,7 @@  import Language.Haskell.Exts hiding (var,app,binds,paren) import Data.List-import Data.Generics.PlateData+import Data.Generics.Uniplate.Data import Data.Data import Data.Char @@ -22,9 +22,32 @@ 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  @@ -38,6 +61,7 @@         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@@ -77,28 +101,31 @@         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 ~= "[]" = TyApp (TyCon (Special ListCon)) y-        fTyp (TyParen x@(TyApp (TyCon (Special ListCon)) _)) = 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 (PApp nam xs) = PApp (rename nam) xs+        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 (transformBi f c) d e) bind-            where-                known = nub [x | UnQual x <- universeBi o]-                f (PVar x) | x `notElem` known = PWildCard-                f x = x+        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@@ -122,11 +149,22 @@         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))) | head xs `notElem` ",)" = UnQual $ Symbol $ init xs+rename (UnQual (Ident ('(':xs@(x:_))))+    | x == ',' = Special $ TupleCon Boxed $ length xs+    | x /= ')' = UnQual $ Symbol $ init xs rename x = x  @@ -179,9 +217,6 @@ showDecls x = unlines $ map prettyPrint x  -unParseOk (ParseOk x) = x-- tyApp x [] = x tyApp x xs = TyApp (tyApp x $ init xs) (last xs) @@ -246,3 +281,9 @@  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 view

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}  module Language.Haskell.Convert(Convert, convert) where @@ -206,3 +206,30 @@  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/Compat.hs view

@@ -0,0 +1,37 @@+{-# 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 view

@@ -1,3 +1,4 @@+ -- | The core module of the Data.Derive system.  This module contains -- the data types used for communication between the extractors and -- the derivors.@@ -8,6 +9,7 @@ import Data.Generics  import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Compat import Language.Haskell.TH.SYB  @@ -30,9 +32,9 @@ dataArity (NewtypeD _ _ xs _ _) = length xs  dataArgs :: DataDef -> [Name]-dataArgs (DataD _cx name args cons _derv) = args-dataArgs (NewtypeD cx name args con derv) = args+dataArgs = dataDefinitionTypeArgs + dataCtors :: DataDef -> [CtorDef] dataCtors (DataD    _ _ _ xs _) = xs dataCtors (NewtypeD _ _ _ x  _) = [x]@@ -115,5 +117,5 @@ isTupleT (TupleT _) = True isTupleT (ConT x) = head sx == '(' && last sx == ')' &&                     all (== ',') (take (length sx - 2) (tail sx))-    where sx = show x+    where sx = nameBase x isTupleT _ = False

Language/Haskell/TH/ExpandSynonym.hs view

@@ -6,6 +6,7 @@ module Language.Haskell.TH.ExpandSynonym (expandData) where  import Language.Haskell.TH+import Language.Haskell.TH.Compat import Language.Haskell.TH.Data import Language.Haskell.TH.Syntax import Language.Haskell.TH.SYB@@ -33,7 +34,7 @@             info <- reify name             case info of                    TyConI (TySynD _ synArgs t) | length args >= length synArgs-                        -> return $ Just (substitute synArgs argsInst t, argsMore) -- instantiate type synonym+                        -> return $ Just (substitute (map fromTyVar synArgs) argsInst t, argsMore) -- instantiate type synonym                              where (argsInst,argsMore) = splitAt (length synArgs) args                    _    -> return Nothing       -- `recover` return Nothing@@ -41,7 +42,7 @@ -- 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` ns) . fst) s) t)+  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)

Language/Haskell/TH/FixedPpr.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell, CPP #-} -- TH.Ppr contains a prettyprinter for the -- Template Haskell datatypes @@ -9,6 +10,7 @@ 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@@ -107,7 +109,11 @@  pprExp :: Precedence -> Exp -> Doc pprExp _ (VarE v)     = ppr v-pprExp _ (ConE c)     = ppr c+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@@ -203,8 +209,14 @@ 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) $ ppr s+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@@ -237,7 +249,7 @@              $ text "deriving"            <+> parens (hsep $ punctuate comma $ map ppr decs)         where pref :: [Doc] -> [Doc]-              pref [] = [char '='] -- Can't happen in H98+              pref [] = [] -- Can't happen in H98               pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds     ppr (NewtypeD ctxt t xs c decs)         = text "newtype"@@ -253,9 +265,21 @@                                 <+> ppr c <+> hsep (map ppr xs) <+> ppr fds                                  $$ where_clause ds     ppr (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i-                             $$ where_clause ds+                             $$ 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@@ -306,7 +330,11 @@ ------------------------------ pprParendType :: Type -> Doc pprParendType (VarT v)   = ppr v-pprParendType (ConT c)   = ppr c+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 "->")@@ -356,3 +384,20 @@  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 view

@@ -10,6 +10,7 @@  import Language.Haskell.TH.Syntax import Language.Haskell.TH.Data+import Language.Haskell.TH.Compat   @@ -60,7 +61,7 @@     where         vrs = vars 't' (dataArity dat)         hed = l1 cls (lK (dataName dat) vrs)-        ctx = [l1 r v | r <- req, v <- vrs]+        ctx = [typeToPred $ l1 r v | r <- req, v <- vrs]   -- | Build an instance of a class for a data type, using the heuristic@@ -74,7 +75,7 @@     where         vrs = vars 't' (dataArity dat)         hed = l1 cls (lK (dataName dat) vrs)-        ctx = map (l1 cls) ctxTypes+        ctx = map (typeToPred . l1 cls) ctxTypes  -- | Build a type signature declaration with a string name sigN :: String -> Type -> Dec

Language/Haskell/TH/SYB.hs view

@@ -2,11 +2,11 @@  module Language.Haskell.TH.SYB where +#ifdef TH_SYB import Data.Generics hiding (Fixity) import Language.Haskell.TH.Syntax import Data.PackedString -#ifdef TH_SYB instance Data PackedString where gfoldl k z x = z x

Main.hs view

@@ -6,6 +6,7 @@ import Derive.Generate import Derive.Test import Derive.Flags+import Data.List   main :: IO ()@@ -24,8 +25,34 @@ mainFile :: [Flag] -> FilePath -> IO () mainFile flags file = do     src <- readFile file-    let modu = unParseOk $ parseFileContents src -- FIXME: with this file mode+    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 modu]-    let res = performDerive (moduleName modu) $ wantDerive flags (src,modu)-    writeDerive file (moduleName modu) flags res+        [(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]

derive.cabal view

@@ -1,9 +1,9 @@ Cabal-Version:  >= 1.6 Build-Type:     Default Name:           derive-Version:        2.0.1+Version:        2.1.0 build-type:     Simple-Copyright:      2006-2009, Neil Mitchell+Copyright:      2006-2010, Neil Mitchell Maintainer:     ndmitchell@gmail.com Homepage:       http://community.haskell.org/~ndm/derive/ License:        BSD3@@ -35,9 +35,9 @@  Library     Build-Depends:-        haskell-src-exts == 1.1.*, filepath, mtl,-        base == 4.*, syb, template-haskell, uniplate, containers,-        pretty, packedstring+        haskell-src-exts == 1.3.* && >= 1.3.2, filepath, mtl,+        base == 4.*, syb, template-haskell, uniplate == 1.3.*, containers,+        pretty      Exposed-Modules:         Data.DeriveTH@@ -51,12 +51,10 @@         Data.Derive.Instance.Arities         Data.Derive.Class.Arities         Data.Derive.Class.Default-        Data.Derive.Internal.Derivation-        Data.Derive.Internal.Instance-        Data.Derive.Internal.Traversal         Language.Haskell         Language.Haskell.Convert         Language.Haskell.TH.All+        Language.Haskell.TH.Compat         Language.Haskell.TH.Data         Language.Haskell.TH.ExpandSynonym         Language.Haskell.TH.FixedPpr@@ -71,6 +69,7 @@         Data.Derive.BinaryDefer         Data.Derive.Bounded         Data.Derive.Data+        Data.Derive.DataAbstract         Data.Derive.Default         Data.Derive.Enum         Data.Derive.EnumCyclic@@ -85,7 +84,6 @@         Data.Derive.Monoid         Data.Derive.NFData         Data.Derive.Ord-        Data.Derive.PlateTypeable         Data.Derive.Read         Data.Derive.Ref         Data.Derive.Serial@@ -93,5 +91,12 @@         Data.Derive.Show         Data.Derive.Traversable         Data.Derive.Typeable+        Data.Derive.UniplateDirect+        Data.Derive.UniplateTypeable         Data.Derive.Update -- GENERATED STOP++    Other-Modules:+        Data.Derive.Internal.Derivation+        Data.Derive.Internal.Instance+        Data.Derive.Internal.Traversal

derive.htm view

@@ -103,12 +103,13 @@ -- GENERATED START --> <li><b><a href='http://hackage.haskell.org/packages/archive/QuickCheck/latest/doc/html/Test-QuickCheck.html#t%3AArbitrary'>Arbitrary</a></b> - from the library <a href='http://hackage.haskell.org/package/QuickCheck'>QuickCheck</a></li>-<li><b><a href='http://hackage.haskell.org/packages/archive/QuickCheck/1.1.0.0/doc/html/Test-QuickCheck.html#t%3AArbitrary'>ArbitraryOld</a></b> - from the library <a href='http://hackage.haskell.org/package/QuickCheck-1.1.0.0'>QuickCheck-1.1.0.0</a></li>+<li><b><a href='http://hackage.haskell.org/packages/archive/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>@@ -123,7 +124,6 @@ <li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Monoid.html#t%3AMonoid'>Monoid</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/parallel/latest/doc/html/Control-Parallel-Strategies.html#t%3ANFData'>NFData</a></b> - from the library <a href='http://hackage.haskell.org/package/parallel'>parallel</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3AOrd'>Ord</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li>-<li><b><a href='http://hackage.haskell.org/packages/archive/uniplate/latest/doc/html/Data-Generics-PlateTypeable.html#t%3APlateAll'>PlateTypeable</a></b> - from the library <a href='http://hackage.haskell.org/package/uniplate'>uniplate</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/base/latest/doc/html/Prelude.html#t%3ARead'>Read</a></b> - from the library <a href='http://hackage.haskell.org/package/base'>base</a></li> <li><b><a href='http://hackage.haskell.org/packages/archive/derive/latest/doc/html/Data-Derive-Ref.html'>Ref</a></b></li> <li><b><a href='http://hackage.haskell.org/packages/archive/smallcheck/latest/doc/html/Test-SmallCheck.html#t%3ASerial'>Serial</a></b> - from the library <a href='http://hackage.haskell.org/package/smallcheck'>smallcheck</a></li>@@ -131,6 +131,8 @@ <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@@ -155,6 +157,15 @@            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> @@ -170,7 +181,7 @@ 	One way is to use CPP. Ensure your compiler is set up for compiling with the C Pre Processor. For example: </p> <pre>-{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_DERIVE --output=file.h #-}  module ModuleName where@@ -193,7 +204,7 @@ <h2>Using Template Haskell Derivations</h2>  <p>-	One of Derive's major advantages over DrIFT is support for the <a href="http://www.haskell.org/th/">Template Haskell</a> (henceforth abbreviated "TH") system.  This allows Derive to be invoked automatically during the compilation process, and (because it occurs with full access to the renamer tables) 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.+	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>