classyplate 0.2.2.0 → 0.3.0.0

raw patch · 3 files changed

+37/−24 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• classyplate.cabal +1/−1
• src/Data/Generics/ClassyPlate/TH.hs +20/−8
• src/Data/Generics/ClassyPlate/TypePrune.hs +16/−15

@@ -1,5 +1,5 @@ name:                classyplate
-version:             0.2.2.0
+version:             0.3.0.0
 synopsis:            Fuseable type-class based generics
 -- description:         
 license:             BSD3

@@ -2,6 +2,7 @@ module Data.Generics.ClassyPlate.TH (makeClassyPlate) where
 
 import Data.Maybe
+import Data.Either
 import Control.Monad
 import Control.Applicative
 
@@ -12,8 +13,10 @@ 
 -- TODO: make the definitions inlineable, and try speed gains by inlining
 
+type PrimitiveMarkers = [Either (Name,Integer) Name]
+
 -- | Creates ClassyPlate instances for a datatype. Can specify which fields should not be traversed.
-makeClassyPlate :: [Name] -> Name -> Q [Dec]
+makeClassyPlate :: PrimitiveMarkers -> Name -> Q [Dec]
 makeClassyPlate primitives dataType 
   = do inf <- reify dataType
        case inf of (TyConI (DataD _ name tvs _ cons _)) -> createClassyPlate name tvs cons
@@ -45,11 +48,13 @@                           (generateAutoDefs clsVar headType name cons)
 
 -- | Creates an @IgnoredFields@ type instance according to the ignored fields specified
-makeIgnoredFieldsTF :: Type -> [Name] -> Dec
+makeIgnoredFieldsTF :: Type -> PrimitiveMarkers -> Dec
 makeIgnoredFieldsTF typ ignored 
   = TySynInstD ''IgnoredFields (TySynEqn [typ] (foldr typeListCons PromotedNilT ignored))
-  where typeListCons :: Name -> Type -> Type
-        typeListCons n = ((PromotedConsT `AppT` (LitT $ StrTyLit $ nameBase n)) `AppT`)
+  where typeListCons :: Either (Name, Integer) Name -> Type -> Type
+        typeListCons (Right fld) = ((PromotedConsT `AppT` (PromotedT 'Right `AppT` (LitT $ StrTyLit $ nameBase fld))) `AppT`)
+        typeListCons (Left (cons, n)) = ((PromotedConsT `AppT` (PromotedT 'Left `AppT` tupType)) `AppT`)
+          where tupType = PromotedTupleT 2 `AppT` (LitT $ StrTyLit $ nameBase cons) `AppT` (LitT $ NumTyLit $ fromIntegral n)
 
 generateCtx :: Name -> Type -> [ConRep] -> Cxt
 generateCtx clsVar selfType cons 
@@ -280,9 +285,16 @@ type ConRep = (Name, [Maybe Type])
 
 -- | Extracts the necessary information from a constructor.
-getConRep :: [Name] -> Con -> ConRep
-getConRep primitives (NormalC n args) = (n, map (Just . snd) args)
-getConRep primitives (RecC n args) = (n, map (\(fldN,_,t) -> if fldN `elem` primitives then Nothing else Just t) args)
-getConRep primitives (InfixC (_,t1) n (_,t2)) = (n, [Just t1, Just t2])
+getConRep :: PrimitiveMarkers -> Con -> ConRep
+getConRep primitives (NormalC n args) 
+  = (n, map (\(i,c) -> if (n,i) `elem` lefts primitives then Nothing else Just (snd c)) (zip [0..] args))
+getConRep primitives (RecC n args) 
+  = (n, map (\(i, (fldN,_,t)) -> if fldN `elem` rights primitives || (n,i) `elem` lefts primitives 
+                                   then Nothing else Just t) 
+          $ zip [0..] args)
+getConRep primitives (InfixC (_,t1) n (_,t2)) 
+  = (n, [ if (n,0) `elem` lefts primitives then Nothing else Just t1
+        , if (n,1) `elem` lefts primitives then Nothing else Just t2
+        ])
 getConRep primitives (ForallC _ _ c) = getConRep primitives c
 getConRep _ _ = error "GADTs are not supported"

@@ -11,7 +11,7 @@ import GHC.Generics
 import Data.Type.Bool
 import Data.Type.List
-import GHC.TypeLits (Symbol)
+import GHC.TypeLits (Symbol, Nat)
 
 -- | This type decides if the subtree of an element cannot contain an element that is transformed.
 type family ClassIgnoresSubtree (cls :: * -> Constraint) (typ :: *) :: Bool where
@@ -27,7 +27,7 @@ 
 -- | This type family sets which fields should not be traversed when trying to generate
 -- automatically pruned versions of classy traversal.
-type family IgnoredFields (t :: *) :: [Symbol]
+type family IgnoredFields (t :: *) :: [Either (Symbol, Nat) Symbol]
 
 type family AnySelected (c :: * -> Constraint) (ls :: [*]) :: Bool where
   AnySelected c (fst ': rest) = AppSelector c fst || AnySelected c rest
@@ -36,27 +36,28 @@ type family MemberTypes (typ :: *) :: [*] where
   MemberTypes t = GetMemberTypes '[] t
 
-type family GetMemberTypes (checked :: [*]) (typ :: *) :: [*] where 
-  -- primitive types without Rep instance
-  GetMemberTypes checked Char = '[Char]
-  GetMemberTypes checked Int = '[Int]
-  GetMemberTypes checked Float = '[Float]
-  GetMemberTypes checked Double = '[Double]
+type family GetMemberTypes (checked :: [*]) (typ :: *) :: [*] where
   GetMemberTypes checked t = GetElementTypes t checked (Rep t)
 
 type family GetElementTypes (t :: *) (checked :: [*]) (typ :: * -> *) :: [*] where 
   GetElementTypes t checked (D1 md cons) = GetElementTypesCons t checked cons
 
 type family GetElementTypesCons (t :: *) (checked :: [*]) (typ :: * -> *) where 
-  GetElementTypesCons t checked (C1 mc flds) = GetElementTypesFields t checked flds
+  GetElementTypesCons t checked (C1 (MetaCons consName pref flag) flds) = GetElementTypesFields consName 0 t checked flds
   GetElementTypesCons t checked (c1 :+: c2) = GetElementTypesCons t checked c1 `Union` GetElementTypesCons t checked c2
 
-type family GetElementTypesFields (t :: *) (checked :: [*]) (typ :: * -> *) where 
-  GetElementTypesFields t checked (fld1 :*: fld2) = GetElementTypesFields t checked fld1 `Union` GetElementTypesFields t checked fld2
-  GetElementTypesFields t checked (S1 (MetaSel (Just fld) unp str laz) (Rec0 innerT)) 
-    = If (Find fld (IgnoredFields t)) '[] (GetElementTypesField checked (Find innerT checked) innerT)
-  GetElementTypesFields t checked (S1 ms (Rec0 innerT)) = GetElementTypesField checked (Find innerT checked) innerT
-  GetElementTypesFields t checked U1 = '[]
+type family GetElementTypesFields (cons :: Symbol) (n :: Nat) (t :: *) (checked :: [*]) (typ :: * -> *) where 
+  GetElementTypesFields cons n t checked (fld1 :*: fld2) 
+    = -- only one field should be on the lhs
+      GetElementTypesFields cons n t checked fld1 `Union` GetElementTypesFields cons n t checked fld2
+  GetElementTypesFields cons n t checked (S1 (MetaSel fld unp str laz) (Rec0 innerT)) 
+    = If (IsIgnoredField cons n fld (IgnoredFields t)) '[] (GetElementTypesField checked (Find innerT checked) innerT)  
+  GetElementTypesFields cons n t checked U1 = '[]
+
+type family IsIgnoredField (cons :: Symbol) (fldNum :: Nat) (fldSelector :: Maybe Symbol)
+                           (ignored :: [Either (Symbol, Nat) Symbol]) :: Bool where
+  IsIgnoredField cons fldNum (Just sel) ignored = Find (Right sel) ignored || Find (Left '(cons, fldNum)) ignored
+  IsIgnoredField cons fldNum Nothing ignored = Find (Left '(cons, fldNum)) ignored
 
 type family GetElementTypesField (checked :: [*]) (inChecked :: Bool) (typ :: *) where 
   GetElementTypesField checked True typ = '[]