classyplate 0.3.0.1 → 0.3.0.2

raw patch · 2 files changed

+10/−6 lines, 2 files

Files

• classyplate.cabal +1/−1
• src/Data/Generics/ClassyPlate/TH.hs +9/−5

@@ -1,5 +1,5 @@ name:                classyplate
-version:             0.3.0.1
+version:             0.3.0.2
 synopsis:            Fuseable type-class based generics
 description:         Defining generics that can be used efficiently on heterogenous data structures 
   like syntax trees. Can access elements of multiple types at a single traversal. Non-invasive method

@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskellQuotes #-} 
-module Data.Generics.ClassyPlate.TH (makeClassyPlate) where
+module Data.Generics.ClassyPlate.TH (makeClassyPlate, makeClassyPlateConfig, ClassyPlateConfig(..)) where
 
 import Data.Maybe
 import Data.Either
@@ -15,9 +15,13 @@ 
 type PrimitiveMarkers = [Either (Name,Integer) Name]
 
+data ClassyPlateConfig = MakeAll | OnlyDirect
+
+makeClassyPlate = makeClassyPlateConfig MakeAll
+
 -- | Creates ClassyPlate instances for a datatype. Can specify which fields should not be traversed.
-makeClassyPlate :: PrimitiveMarkers -> Name -> Q [Dec]
-makeClassyPlate primitives dataType 
+makeClassyPlateConfig :: ClassyPlateConfig -> PrimitiveMarkers -> Name -> Q [Dec]
+makeClassyPlateConfig config primitives dataType 
   = do inf <- reify dataType
        case inf of (TyConI (DataD _ name tvs _ cons _)) -> createClassyPlate name tvs cons
                    (TyConI (NewtypeD _ name tvs _ con _)) -> createClassyPlate name tvs [con]
@@ -25,9 +29,9 @@   where createClassyPlate name tvs cons 
           = let headType = foldl AppT (ConT name) (map (VarT . getTVName) tvs)
              in return $ [ makeNormalCPForDataType name headType tvs (map (getConRep primitives) cons)
-                         , makeAutoCPForDataType name headType tvs (map (getConRep primitives) cons)
                          , makeIgnoredFieldsTF headType primitives
-                         ]
+                         ] ++ case config of MakeAll -> [ makeAutoCPForDataType name headType tvs (map (getConRep primitives) cons) ]
+                                             _       -> []
 
 makeNormalCPForDataType :: Name -> Type -> [TyVarBndr] -> [ConRep] -> Dec
 makeNormalCPForDataType name headType tvs cons