packages feed

classyplate (empty) → 0.1.0.0

raw patch · 8 files changed

+523/−0 lines, 8 filesdep +basedep +template-haskelldep +type-listsetup-changed

Dependencies added: base, template-haskell, type-list

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for classyplate
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, N‚meth Boldizs r
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of N‚meth Boldizs r nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ classyplate.cabal view
@@ -0,0 +1,22 @@+name:                classyplate
+version:             0.1.0.0
+synopsis:            Fuseable type-class based generics
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              Nemeth Boldizsar
+maintainer:          nboldi@elte.hu
+-- copyright:           
+category:            Data
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Data.Generics.ClassyPlate
+                     , Data.Generics.ClassyPlate.TypePrune
+                     , Data.Generics.ClassyPlate.TH
+                     , Data.Generics.ClassyPlate.Core
+  build-depends:       base >=4.9 && <4.10, type-list >=0.5 && <0.6, template-haskell >=2.11 && <2.12
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+ src/Data/Generics/ClassyPlate.hs view
@@ -0,0 +1,9 @@+module Data.Generics.ClassyPlate 
+  ( module Data.Generics.ClassyPlate.Core
+  , module Data.Generics.ClassyPlate.TH
+  , module Data.Generics.ClassyPlate.TypePrune
+  ) where
+
+import Data.Generics.ClassyPlate.Core
+import Data.Generics.ClassyPlate.TH
+import Data.Generics.ClassyPlate.TypePrune
+ src/Data/Generics/ClassyPlate/Core.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE Rank2Types
+           , ConstraintKinds
+           , KindSignatures
+           , TypeFamilies
+           , ScopedTypeVariables
+           , MultiParamTypeClasses
+           , AllowAmbiguousTypes
+           , FlexibleContexts
+           , FlexibleInstances
+           , UndecidableInstances
+           , DataKinds
+           , TypeApplications
+           , DeriveGeneric
+           , DeriveDataTypeable
+           , TypeOperators
+           , PolyKinds 
+           #-}
+module Data.Generics.ClassyPlate.Core
+  ( -- public functions and classes
+    classyTraverse, classyTraverseM, selectiveTraverse, selectiveTraverseM, smartTraverse, smartTraverseM
+  , ClassyPlate, SmartClassyPlate
+    -- generator functions and datatypes
+  , classyTraverse_, classyTraverseM_, selectiveTraverse_, selectiveTraverseM_, smartTraverse_, smartTraverseM_
+  , app, appM, appIf, appIfM
+  , GoodOperationFor, GoodOperationForAuto, FlagToken
+    -- MonoMatch
+  , MonoMatch (..)
+
+  ) where
+
+import GHC.Exts
+import Data.Maybe
+import GHC.Generics (Generic)
+import Data.Data (Data)
+
+import Data.Generics.ClassyPlate.TypePrune
+
+-- FIXME: when TH supports type application we can remove the token parameters
+
+type GoodOperationFor c e = (App (AppSelector c e) c e)
+type GoodOperationForAuto c e = (GoodOperationFor c e, Generic e)
+
+data ClsToken (c :: * -> Constraint)
+data FlagToken (c :: Bool)
+
+-- | A class for applying a function if the class of the functions allows the application
+class App (flag :: Bool) c b where
+  app :: FlagToken flag -> ClsToken c -> (forall a . c a => a -> a) -> b -> b
+  appM :: Monad m => FlagToken flag -> ClsToken c -> (forall a . c a => a -> m a) -> b -> m b
+  appPred :: FlagToken flag -> ClsToken c -> (forall a . c a => a -> Bool) -> b -> b -> b
+  appPredM :: Monad m => FlagToken flag -> ClsToken c -> (forall a . c a => a -> m Bool) -> b -> m b -> m b
+
+instance c b => App 'True c b where
+  {-# INLINE app #-}
+  app _ _ f a = f a
+  {-# INLINE appM #-}
+  appM _ _ f a = f a
+  {-# INLINE appPred #-}
+  appPred _ _ f th el = if f th then el else th
+  {-# INLINE appPredM #-}
+  appPredM _ _ f th el = f th >>= \p -> if p then el else return th
+
+instance App 'False c b where
+  {-# INLINE app #-}
+  app _ _ _ a = a
+  {-# INLINE appM #-}
+  appM _ _ _ a = return a
+  {-# INLINE appPred #-}
+  appPred _ _ _ _ el = el
+  {-# INLINE appPredM #-}
+  appPredM _ _ _ _ el = el
+
+-- | A class for traversals that use a polymorphic function to visit all applicable elements.
+class GoodOperationFor c b => ClassyPlate c b where
+  classyTraverse_ :: ClsToken c -> (forall a . c a => a -> a) -> b -> b
+  classyTraverseM_ :: Monad m => ClsToken c -> (forall a . c a => a -> m a) -> b -> m b
+
+  selectiveTraverse_ :: ClsToken c -> (forall a . c a => a -> a) -> (forall a . c a => a -> Bool) -> b -> b
+  selectiveTraverseM_ :: Monad m => ClsToken c -> (forall a . c a => a -> m a) -> (forall a . c a => a -> m Bool) -> b -> m b
+
+-- | A class for traversals that use a polymorphic function to visit all applicable elements but only visit the 
+-- parts where the applicable elements could be found.
+class (GoodOperationForAuto c b) => SmartClassyPlate c (sel :: Bool) b where
+  smartTraverse_ :: FlagToken sel -> ClsToken c -> (forall a . c a => a -> a) -> b -> b
+  smartTraverseM_ :: Monad m => FlagToken sel -> ClsToken c -> (forall a . c a => a -> m a) -> b -> m b
+
+-- | Traverse the data structure with a polymorphic function.
+classyTraverse :: forall c b . ClassyPlate c b => (forall a . c a => a -> a) -> b -> b
+{-# INLINE classyTraverse #-}
+classyTraverse = classyTraverse_ (undefined :: ClsToken c)
+
+-- | Traverse the data structure with a polymorphic monadic function.
+classyTraverseM :: forall c b m . (ClassyPlate c b, Monad m) => (forall a . c a => a -> m a) -> b -> m b
+{-# INLINE classyTraverseM #-}
+classyTraverseM = classyTraverseM_ (undefined :: ClsToken c)
+
+-- | Traverse only those parts that are selected by the given selector function. 
+selectiveTraverse :: forall c b . ClassyPlate c b => (forall a . c a => a -> a) -> (forall a . c a => a -> Bool) -> b -> b
+{-# INLINE selectiveTraverse #-}
+selectiveTraverse = selectiveTraverse_ (undefined :: ClsToken c)
+
+-- | Traverse only those parts that are selected by the given monadic selector function.
+selectiveTraverseM :: forall c b m . (ClassyPlate c b, Monad m) => (forall a . c a => a -> m a) -> (forall a . c a => a -> m Bool) -> b -> m b
+{-# INLINE selectiveTraverseM #-}
+selectiveTraverseM = selectiveTraverseM_ (undefined :: ClsToken c)
+
+-- | Traverse only those parts of the data structure that could possibly contain elements that the given function can be applied on
+smartTraverse :: forall c b . SmartClassyPlate c (ClassIgnoresSubtree c b) b => (forall a . c a => a -> a) -> b -> b
+{-# INLINE smartTraverse #-}
+smartTraverse = smartTraverse_ (undefined :: FlagToken (ClassIgnoresSubtree c b)) (undefined :: ClsToken c)
+
+-- | Traverse only those parts of the data structure that could possibly contain elements that the given monadic function can be applied on
+smartTraverseM :: forall c b m . (SmartClassyPlate c (ClassIgnoresSubtree c b) b, Monad m) => (forall a . c a => a -> m a) -> b -> m b
+{-# INLINE smartTraverseM #-}
+smartTraverseM = smartTraverseM_ (undefined :: FlagToken (ClassIgnoresSubtree c b)) (undefined :: ClsToken c)
+
+instance (GoodOperationForAuto c b) => SmartClassyPlate c True b where
+  smartTraverse_ _ t f a = app (undefined :: FlagToken (AppSelector c b)) t f a
+  {-# INLINE smartTraverse_ #-}
+  smartTraverseM_ _ t f a = appM (undefined :: FlagToken (AppSelector c b)) t f a
+  {-# INLINE smartTraverseM_ #-}
+
+{-# SPECIALIZE INLINE classyTraverse_ :: ClassyPlate (MonoMatch x) sel b => (forall a . MonoMatch x a => a -> a) -> b -> b #-}
+
+-- | A class for the simple case when the applied function is monomorphic.
+class MonoMatch a b where
+  -- | Apply a monomorphic function on a polymorphic data structure.
+  monoApp :: (a -> a) -> b -> b
+
+instance MonoMatch a a where
+  monoApp = id
+  {-# INLINE monoApp #-}
+
+type instance AppSelector (MonoMatch a) b = TypEq a b
+
+type family TypEq a b :: Bool where
+  TypEq a a = 'True
+  TypEq a b = 'False
+
+appIf :: forall c b . App (AppSelector c b) c b => ClsToken c -> (forall a . c a => a -> a) -> (forall a . c a => a -> Bool) -> b -> b -> b
+{-# INLINE appIf #-}
+appIf t f pred val combined = app flTok t f $ appPred flTok t pred val combined
+  where flTok = undefined :: FlagToken (AppSelector c b)
+
+appIfM :: forall c b m . (App (AppSelector c b) c b, Monad m) => ClsToken c -> (forall a . c a => a -> m a) -> (forall a . c a => a -> m Bool) -> b -> m b -> m b
+{-# INLINE appIfM #-}
+appIfM t f pred val combined = appM flTok t f =<< appPredM flTok t pred val combined
+  where flTok = undefined :: FlagToken (AppSelector c b)
+ src/Data/Generics/ClassyPlate/TH.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE TemplateHaskellQuotes #-} 
+module Data.Generics.ClassyPlate.TH (makeClassyPlate) where
+
+import Data.Maybe
+import Control.Monad
+import Control.Applicative
+
+import Language.Haskell.TH
+
+import Data.Generics.ClassyPlate.Core
+import Data.Generics.ClassyPlate.TypePrune
+
+-- TODO: make the definitions inlineable, and try speed gains by inlining
+
+-- | Creates ClassyPlate instances for a datatype. Can specify which fields should not be traversed.
+makeClassyPlate :: [Name] -> Name -> Q [Dec]
+makeClassyPlate primitives dataType 
+  = do inf <- reify dataType
+       case inf of (TyConI (DataD _ 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
+                                     ]
+
+makeNormalCPForDataType :: Name -> Type -> [TyVarBndr] -> [ConRep] -> Dec
+makeNormalCPForDataType name headType tvs cons
+  = let clsVar = mkName "c"
+     in InstanceD Nothing (generateCtx clsVar headType cons) 
+                          (ConT ''ClassyPlate `AppT` VarT clsVar `AppT` headType) 
+                          (generateDefs clsVar headType name cons)
+
+-- | Creates the @ClassyPlate@
+makeAutoCPForDataType :: Name -> Type -> [TyVarBndr] -> [ConRep] -> Dec
+makeAutoCPForDataType name headType tvs cons
+  = let clsVar = mkName "c"
+     in InstanceD Nothing (generateAutoCtx clsVar headType cons) 
+                          (ConT ''SmartClassyPlate 
+                            `AppT` VarT clsVar 
+                            `AppT` ConT 'False  
+                            `AppT` headType) 
+                          (generateAutoDefs clsVar headType name cons)
+
+-- | Creates an @IgnoredFields@ type instance according to the ignored fields specified
+makeIgnoredFieldsTF :: Type -> [Name] -> 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`)
+
+generateCtx :: Name -> Type -> [ConRep] -> Cxt
+generateCtx clsVar selfType cons 
+  = (ConT ''GoodOperationFor `AppT` VarT clsVar `AppT` selfType) 
+      : map ((ConT ''ClassyPlate `AppT` VarT clsVar) `AppT`) (concatMap (\(_, args) -> catMaybes args) cons)
+
+-- | Generates the body of the instance definitions for normal classyplates
+generateDefs :: Name -> Type -> Name -> [ConRep] -> [Dec]
+generateDefs clsVar headType tyName cons = 
+  [ FunD 'classyTraverse_ (map (generateAppClause clsVar headType tyName) cons)
+  , FunD 'classyTraverseM_ (map (generateAppMClause clsVar headType tyName) cons)
+  , FunD 'selectiveTraverse_ (map (generateSelectiveAppClause tyName) cons)
+  , FunD 'selectiveTraverseM_ (map (generateSelectiveAppMClause tyName) cons)
+  ]
+
+
+generateAutoCtx :: Name -> Type -> [ConRep] -> Cxt
+generateAutoCtx clsVar selfType cons 
+  = (ConT ''GoodOperationForAuto `AppT` VarT clsVar `AppT` selfType) 
+      : map (\t -> (ConT ''SmartClassyPlate `AppT` VarT clsVar
+                      `AppT` (ConT ''ClassIgnoresSubtree `AppT` VarT clsVar `AppT` t)) `AppT` t)
+            (concatMap (\(_, args) -> catMaybes args) cons)
+
+-- | Generates the body of the instance definition for auto classy plate
+generateAutoDefs :: Name -> Type -> Name -> [ConRep] -> [Dec]
+generateAutoDefs clsVar headType tyName cons = 
+  [ FunD 'smartTraverse_ (map (generateAppAutoClause clsVar headType tyName) cons)
+  , FunD 'smartTraverseM_ (map (generateAppAutoMClause clsVar headType tyName) cons)
+  ]
+
+-- * Normal definitions
+
+-- | Creates the clause for the @classyTraverse_@ function for one constructor: @classyTraverse_ t f (Add e1 e2) = app (undefined :: FlagToken (AppSelector c (Expr dom stage))) t f $ Add (apply t f e1) (apply t f e2)@
+generateAppClause :: Name -> Type -> Name -> ConRep -> Clause
+generateAppClause clsVar headType tyName (conName, args) 
+  = Clause [VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)] 
+      (NormalB (generateAppExpr clsVar headType tokenName funName 
+                 `AppE` generateRecombineExpr conName tokenName funName (zip (map isJust args) argNames))) []
+  where argNames = map (mkName . ("a"++) . show) [0..]
+        tokenName = mkName "t"
+        funName = mkName "f"
+
+generateAppExpr :: Name -> Type -> Name -> Name -> Exp
+generateAppExpr clsVar headType tokenName funName
+  = VarE 'app `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''AppSelector `AppT` VarT clsVar `AppT` headType)))
+              `AppE` VarE tokenName `AppE` VarE funName
+
+generateRecombineExpr :: Name -> Name -> Name -> [(Bool, Name)] -> Exp
+generateRecombineExpr conName tokenName funName args
+  = foldl AppE (ConE conName) (map mapArgRep args)
+  where mapArgRep (True, n) = VarE 'classyTraverse_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
+        mapArgRep (False, n) = VarE n
+
+-- * Monadic definitions
+
+-- | Creates the clause for the @classyTraverseM_@ function for one constructor: @classyTraverseM_ t f (Ann ann e) = appM (undefined :: FlagToken (AppSelector c (Ann e dom stage))) t f =<< (Ann <$> return ann <*> applyM t f e)@
+generateAppMClause :: Name -> Type -> Name -> ConRep -> Clause
+generateAppMClause clsVar headType tyName (conName, args) 
+  = Clause [VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)] 
+      (NormalB (InfixE (Just $ generateAppMExpr clsVar headType tokenName funName)
+                       (VarE '(=<<))
+                       (Just $ generateRecombineMExpr conName tokenName funName (zip (map isJust args) argNames)) )) []
+  where argNames = map (mkName . ("a"++) . show) [0..]
+        tokenName = mkName "t"
+        funName = mkName "f"
+
+generateAppMExpr :: Name -> Type -> Name -> Name -> Exp
+generateAppMExpr clsVar headType tokenName funName
+  = VarE 'appM `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''AppSelector `AppT` VarT clsVar `AppT` headType)))
+               `AppE` VarE tokenName `AppE` VarE funName
+
+generateRecombineMExpr :: Name -> Name -> Name -> [(Bool, Name)] -> Exp
+generateRecombineMExpr conName tokenName funName []
+  = AppE (VarE 'return) (ConE conName)
+generateRecombineMExpr conName tokenName funName (fst:args)
+  = foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just) 
+          (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst)) 
+          (map mapArgRep args)
+  where mapArgRep (True, n) = VarE 'classyTraverseM_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
+        mapArgRep (False, n) = VarE 'return `AppE` VarE n
+
+-- * Selective definitions
+
+-- | Creates the clause for the @selectiveTraverse_@ function for one constructor: @selectiveTraverse_ t f pred val@(CB b) = appIf t f pred val (CB (applySelective t f pred b))@
+generateSelectiveAppClause :: Name -> ConRep -> Clause
+generateSelectiveAppClause tyName (conName, args) 
+  = Clause [VarP tokenName, VarP funName, VarP predName, AsP valName $ ConP conName (map VarP $ take (length args) argNames)] 
+      (NormalB (generateAppIfExpr tokenName funName predName valName
+                 `AppE` generateSelectiveRecombineExpr conName tokenName funName predName (zip (map isJust args) argNames))) []
+  where argNames = map (mkName . ("a"++) . show) [0..]
+        tokenName = mkName "t"
+        funName = mkName "f"
+        predName = mkName "p"
+        valName = mkName "v"
+
+generateAppIfExpr :: Name -> Name -> Name -> Name -> Exp
+generateAppIfExpr tokenName funName predName valName
+  = VarE 'appIf `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE predName `AppE` VarE valName
+
+generateSelectiveRecombineExpr :: Name -> Name -> Name -> Name -> [(Bool, Name)] -> Exp
+generateSelectiveRecombineExpr conName tokenName funName predName args
+  = foldl AppE (ConE conName) (map mapArgRep args)
+  where mapArgRep (True, n) = VarE 'selectiveTraverse_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE predName `AppE` VarE n
+        mapArgRep (False, n) = VarE n
+
+-- * Monadic selective definitions
+
+-- | Creates the clause for the @selectiveTraverseM_@ function for one constructor:
+generateSelectiveAppMClause :: Name -> ConRep -> Clause
+generateSelectiveAppMClause tyName (conName, args) 
+  = Clause [VarP tokenName, VarP funName, VarP predName, AsP valName $ ConP conName (map VarP $ take (length args) argNames)] 
+      (NormalB (generateAppIfMExpr tokenName funName predName valName
+                 `AppE` generateSelectiveRecombineMExpr conName tokenName funName predName (zip (map isJust args) argNames))) []
+  where argNames = map (mkName . ("a"++) . show) [0..]
+        tokenName = mkName "t"
+        funName = mkName "f"
+        predName = mkName "p"
+        valName = mkName "v"
+
+generateAppIfMExpr :: Name -> Name -> Name -> Name -> Exp
+generateAppIfMExpr tokenName funName predName valName
+  = VarE 'appIfM `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE predName `AppE` VarE valName
+
+generateSelectiveRecombineMExpr :: Name -> Name -> Name -> Name -> [(Bool, Name)] -> Exp
+generateSelectiveRecombineMExpr conName tokenName funName predName []
+  = AppE (VarE 'return) (ConE conName)
+generateSelectiveRecombineMExpr conName tokenName funName predName (fst:args)
+  = foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just) 
+          (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst)) 
+          (map mapArgRep args)
+  where mapArgRep (True, n) = VarE 'selectiveTraverseM_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE predName `AppE` VarE n
+        mapArgRep (False, n) = VarE 'return `AppE` VarE n
+
+-- * Automatic definitions
+
+-- | Creates the clause for the @smartTraverse_@ function for one constructor
+generateAppAutoClause :: Name -> Type -> Name -> ConRep -> Clause
+generateAppAutoClause clsVar headType tyName (conName, args) 
+  = Clause [WildP, VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)] 
+      (NormalB (generateAppExpr clsVar headType tokenName funName 
+                 `AppE` generateAutoRecombineExpr clsVar conName tokenName funName (zip args argNames))) []
+  where argNames = map (mkName . ("a"++) . show) [0..]
+        tokenName = mkName "t"
+        funName = mkName "f"
+
+generateAutoRecombineExpr :: Name -> Name -> Name -> Name -> [(Maybe Type, Name)] -> Exp
+generateAutoRecombineExpr clsVar conName tokenName funName args
+  = foldl AppE (ConE conName) (map mapArgRep args)
+  where mapArgRep (Just t, n) 
+          = VarE 'smartTraverse_ 
+              `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''ClassIgnoresSubtree `AppT` VarT clsVar `AppT` t))) 
+              `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
+        mapArgRep (Nothing, n) = VarE n
+
+-- * Monadic automatic definitions
+
+-- | Creates the clause for the @smartTraverseM_@ function for one constructor
+generateAppAutoMClause :: Name -> Type -> Name -> ConRep -> Clause
+generateAppAutoMClause clsVar headType tyName (conName, args) 
+  = Clause [WildP, VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)] 
+      (NormalB (InfixE (Just $ generateAppMExpr clsVar headType tokenName funName)
+                       (VarE '(=<<))
+                       (Just $ generateAutoRecombineMExpr clsVar conName tokenName funName (zip args argNames)) )) []
+  where argNames = map (mkName . ("a"++) . show) [0..]
+        tokenName = mkName "t"
+        funName = mkName "f"
+
+generateAutoRecombineMExpr :: Name -> Name -> Name -> Name -> [(Maybe Type, Name)] -> Exp
+generateAutoRecombineMExpr _ conName tokenName funName []
+  = AppE (VarE 'return) (ConE conName)
+generateAutoRecombineMExpr clsVar conName tokenName funName (fst:args)
+  = foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just) 
+          (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst)) 
+          (map mapArgRep args)
+  where mapArgRep (Just t, n) 
+          = VarE 'smartTraverseM_ 
+             `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''ClassIgnoresSubtree `AppT` VarT clsVar `AppT` t))) 
+             `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
+        mapArgRep (Nothing, n) = VarE 'return `AppE` VarE n
+
+-- | Gets the name of a type variable
+getTVName :: TyVarBndr -> Name
+getTVName (PlainTV n) = n
+getTVName (KindedTV n _) = n
+
+-- | The information we need from a constructor.
+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 primitives (ForallC _ _ c) = getConRep primitives c
+getConRep _ _ = error "GADTs are not supported"
+ src/Data/Generics/ClassyPlate/TypePrune.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE KindSignatures
+           , TypeOperators
+           , DataKinds
+           , PolyKinds
+           , TypeFamilies
+           , UndecidableInstances
+           #-}
+module Data.Generics.ClassyPlate.TypePrune (ClassIgnoresSubtree, AppSelector, AppPruning, IgnoredFields) where
+
+import GHC.Exts (Constraint)
+import GHC.Generics
+import Data.Type.Bool
+import Data.Type.List
+import GHC.TypeLits (Symbol)
+
+-- | This type decides if the subtree of an element cannot contain an element that is transformed.
+type family ClassIgnoresSubtree (cls :: * -> Constraint) (typ :: *) :: Bool where
+  ClassIgnoresSubtree cls typ = Not (AnySelected cls (MemberTypes typ))
+
+-- | Instantiate this type family to signal what elements does your operation operate on.
+-- If @AppSelector c t@ is True, there should be a @c t@ instance. AppSelector should be
+-- a total type function for a given class, at least for all the types that can possibly
+-- accessed.
+type family AppSelector (c :: * -> Constraint) (a :: *) :: Bool
+
+type family AppPruning (c :: * -> Constraint) (a :: *) :: Bool
+
+-- | 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 AnySelected (c :: * -> Constraint) (ls :: [*]) :: Bool where
+  AnySelected c (fst ': rest) = AppSelector c fst || AnySelected c rest
+  AnySelected c '[] = False
+
+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]
+  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 :+: 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 GetElementTypesField (checked :: [*]) (inChecked :: Bool) (typ :: *) where 
+  GetElementTypesField checked True typ = '[]
+  GetElementTypesField checked False typ = Insert typ (GetMemberTypes (typ ': checked) typ)