packages feed

classyplate 0.3.0.2 → 0.3.1.0

raw patch · 3 files changed

+72/−77 lines, 3 filesdep ~basedep ~template-haskell

Dependency ranges changed: base, template-haskell

Files

classyplate.cabal view
@@ -1,7 +1,7 @@ name:                classyplate
-version:             0.3.0.2
+version:             0.3.1.0
 synopsis:            Fuseable type-class based generics
-description:         Defining generics that can be used efficiently on heterogenous data structures 
+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
   don't have to change the representation to use. All boilerplate code can be generated by the supplied
   Template Haskell functions.
@@ -25,8 +25,8 @@                      , Data.Generics.ClassyPlate.TypePrune
                      , Data.Generics.ClassyPlate.TH
                      , Data.Generics.ClassyPlate.Core
-  build-depends:       base             >=4.10   && <4.11
-                     , template-haskell >=2.12  && <2.13
+  build-depends:       base             >=4.10   && <4.12
+                     , template-haskell >=2.12  && <2.14
   hs-source-dirs:      src
   default-language:    Haskell2010
src/Data/Generics/ClassyPlate/Core.hs view
@@ -13,7 +13,7 @@            , DeriveGeneric
            , DeriveDataTypeable
            , TypeOperators
-           , PolyKinds 
+           , PolyKinds
            #-}
 module Data.Generics.ClassyPlate.Core
   ( -- public functions and classes
@@ -24,14 +24,11 @@ 
   , app, appM, appTD, appTDM
   , GoodOperationFor, GoodOperationForAuto, FlagToken
-  , ClsToken, FlagToken
+  , ClsToken
   ) where
 
 import GHC.Exts
-import Data.Maybe
-import Control.Monad
 import GHC.Generics (Generic)
-import Data.Data (Data)
 
 import Data.Generics.ClassyPlate.TypePrune
 
@@ -75,7 +72,7 @@   topDown_ :: ClsToken c -> (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
   topDownM_ :: Monad m => ClsToken c -> (forall a . (ClassyPlate c a, c a) => a -> m a) -> b -> m b
 
--- | A class for traversals that use a polymorphic function to visit all applicable elements but only visit the 
+-- | 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 . (ClassyPlate c a, c a) => a -> a) -> b -> b
src/Data/Generics/ClassyPlate/TH.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE TemplateHaskellQuotes #-} 
+{-# LANGUAGE TemplateHaskellQuotes #-}
 module Data.Generics.ClassyPlate.TH (makeClassyPlate, makeClassyPlateConfig, ClassyPlateConfig(..)) where
 
 import Data.Maybe
 import Data.Either
-import Control.Monad
-import Control.Applicative
 
 import Language.Haskell.TH
 
@@ -21,12 +19,12 @@ 
 -- | Creates ClassyPlate instances for a datatype. Can specify which fields should not be traversed.
 makeClassyPlateConfig :: ClassyPlateConfig -> PrimitiveMarkers -> Name -> Q [Dec]
-makeClassyPlateConfig config primitives dataType 
+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]
                    _ -> error $ "Cannot create classyplate for " ++ show dataType ++ " only data and newtype declarations are supported."
-  where createClassyPlate name tvs cons 
+  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)
                          , makeIgnoredFieldsTF headType primitives
@@ -34,26 +32,26 @@                                              _       -> []
 
 makeNormalCPForDataType :: Name -> Type -> [TyVarBndr] -> [ConRep] -> Dec
-makeNormalCPForDataType name headType tvs cons
+makeNormalCPForDataType name headType _ cons
   = let clsVar = mkName "c"
-     in InstanceD Nothing (generateCtx clsVar headType cons) 
-                          (ConT ''ClassyPlate `AppT` VarT clsVar `AppT` headType) 
+     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
+makeAutoCPForDataType name headType _ cons
   = let clsVar = mkName "c"
-     in InstanceD Nothing (generateAutoCtx clsVar headType cons) 
-                          (ConT ''SmartClassyPlate 
-                            `AppT` VarT clsVar 
-                            `AppT` ConT 'False  
-                            `AppT` headType) 
+     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 -> PrimitiveMarkers -> Dec
-makeIgnoredFieldsTF typ ignored 
+makeIgnoredFieldsTF typ ignored
   = TySynInstD ''IgnoredFields (TySynEqn [typ] (foldr typeListCons PromotedNilT ignored))
   where typeListCons :: Either (Name, Integer) Name -> Type -> Type
         typeListCons (Right fld) = ((PromotedConsT `AppT` (PromotedT 'Right `AppT` (LitT $ StrTyLit $ nameBase fld))) `AppT`)
@@ -61,13 +59,13 @@           where tupType = PromotedTupleT 2 `AppT` (LitT $ StrTyLit $ nameBase cons) `AppT` (LitT $ NumTyLit $ fromIntegral n)
 
 generateCtx :: Name -> Type -> [ConRep] -> Cxt
-generateCtx clsVar selfType cons 
-  = (ConT ''GoodOperationFor `AppT` VarT clsVar `AppT` selfType) 
+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 = 
+generateDefs clsVar headType tyName cons =
   [ FunD 'bottomUp_ (map (generateAppClause clsVar headType tyName) cons)
   , FunD 'bottomUpM_ (map (generateAppMClause clsVar headType tyName) cons)
   , FunD 'topDown_ [generateTopDownClause generateTopDownExpr clsVar headType cons]
@@ -78,15 +76,15 @@ 
 
 generateAutoCtx :: Name -> Type -> [ConRep] -> Cxt
-generateAutoCtx clsVar selfType cons 
-  = (ConT ''GoodOperationForAuto `AppT` VarT clsVar `AppT` selfType) 
+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 = 
+generateAutoDefs clsVar headType tyName cons =
   [ FunD 'smartTraverse_ (map (generateAppAutoClause clsVar headType tyName) cons)
   , FunD 'smartTraverseM_ (map (generateAppAutoMClause clsVar headType tyName) cons)
   ]
@@ -95,9 +93,9 @@ 
 -- | 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 (classyTraverse_ t f e1) (classyTraverse_ 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 
+generateAppClause clsVar headType _ (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"
@@ -118,8 +116,8 @@ 
 -- | 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)] 
+generateAppMClause clsVar headType _ (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)) )) []
@@ -133,11 +131,11 @@                `AppE` VarE tokenName `AppE` VarE funName
 
 generateRecombineMExpr :: Name -> Name -> Name -> [(Bool, Name)] -> Exp
-generateRecombineMExpr conName tokenName funName []
+generateRecombineMExpr conName _ _ []
   = 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)) 
+  = foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just)
+          (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst))
           (map mapArgRep args)
   where mapArgRep (True, n) = VarE 'bottomUpM_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
         mapArgRep (False, n) = VarE 'return `AppE` VarE n
@@ -158,12 +156,12 @@           (map (createTopDownMatch tokenName funName) cons)
 
 createTopDownMatch :: Name -> Name -> ConRep -> Match
-createTopDownMatch tokenName funName (conName, args) 
-  = Match (ConP conName (map VarP formalArgs)) 
+createTopDownMatch tokenName funName (conName, args)
+  = Match (ConP conName (map VarP formalArgs))
           (NormalB $ foldl AppE (ConE conName) (map mapArgRep $ zip args formalArgs)) []
   where argNames = map (mkName . ("a"++) . show) [0..]
         formalArgs = take (length args) argNames
-        mapArgRep (Just t, n) = VarE 'topDown_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
+        mapArgRep (Just _, n) = VarE 'topDown_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
         mapArgRep (Nothing, n) = VarE n
 
 -- * Monadic top-down
@@ -178,16 +176,16 @@ 
 generateTopDownMMatch :: Name -> Name -> ConRep -> Match
 generateTopDownMMatch tokenName funName (conName, args)
-  = Match (ConP conName (map VarP argNames)) 
-          (NormalB $ case formalArgs of 
+  = Match (ConP conName (map VarP argNames))
+          (NormalB $ case formalArgs of
                        [] -> VarE 'return `AppE` ConE conName
-                       fst:rest -> foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just) 
-                                         (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst)) 
+                       fst:rest -> foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just)
+                                         (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst))
                                          (map mapArgRep rest)
           ) []
   where argNames = take (length args) $ map (mkName . ("a"++) . show) [0..]
         formalArgs = zip args argNames
-        mapArgRep (Just t, n) = VarE 'topDownM_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
+        mapArgRep (Just _, n) = VarE 'topDownM_ `AppE` VarE tokenName `AppE` VarE funName `AppE` VarE n
         mapArgRep (Nothing, n) = VarE 'return `AppE` VarE n
 
 
@@ -195,8 +193,8 @@ 
 -- | Creates the clause for the @descend_@ function for one constructor
 generateDescendAppClause :: Name -> Type -> Name -> ConRep -> Clause
-generateDescendAppClause clsVar headType tyName (conName, args) 
-  = Clause [VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)] 
+generateDescendAppClause clsVar _ _ (conName, args)
+  = Clause [VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)]
       (NormalB (generateDescendRecombineExpr clsVar conName tokenName funName (zip args argNames))) []
   where argNames = map (mkName . ("a"++) . show) [0..]
         tokenName = mkName "t"
@@ -205,8 +203,8 @@ generateDescendRecombineExpr :: Name -> Name -> Name -> Name -> [(Maybe Type, Name)] -> Exp
 generateDescendRecombineExpr clsVar conName tokenName funName args
   = foldl AppE (ConE conName) (map mapArgRep args)
-  where mapArgRep (Just t, n) = VarE 'appTD `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''AppSelector `AppT` VarT clsVar `AppT` t))) 
-                                            `AppE` VarE tokenName `AppE` VarE funName 
+  where mapArgRep (Just t, n) = VarE 'appTD `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''AppSelector `AppT` VarT clsVar `AppT` t)))
+                                            `AppE` VarE tokenName `AppE` VarE funName
                                             `AppE` (VarE 'descend_ `AppE` VarE tokenName `AppE` VarE funName) `AppE` VarE n
         mapArgRep (Nothing, n) = VarE n
 
@@ -214,22 +212,22 @@ 
 -- | Creates the clause for the @descendM_@ function for one constructor
 generateDescendMAppClause :: Name -> Type -> Name -> ConRep -> Clause
-generateDescendMAppClause clsVar headType tyName (conName, args) 
-  = Clause [VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)] 
+generateDescendMAppClause clsVar _ _ (conName, args)
+  = Clause [VarP tokenName, VarP funName, ConP conName (map VarP $ take (length args) argNames)]
       (NormalB (generateDescendMRecombineExpr clsVar conName tokenName funName (zip args argNames))) []
   where argNames = map (mkName . ("a"++) . show) [0..]
         tokenName = mkName "t"
         funName = mkName "f"
 
 generateDescendMRecombineExpr :: Name -> Name -> Name -> Name -> [(Maybe Type, Name)] -> Exp
-generateDescendMRecombineExpr clsVar conName tokenName funName []
+generateDescendMRecombineExpr _ conName _ _ []
   = AppE (VarE 'return) (ConE conName)
 generateDescendMRecombineExpr clsVar conName tokenName funName (fst:args)
-  = foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just) 
-          (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst)) 
+  = foldl (\base -> InfixE (Just base) (VarE '(<*>)) . Just)
+          (InfixE (Just $ ConE conName) (VarE '(<$>)) (Just $ mapArgRep fst))
           (map mapArgRep args)
-  where mapArgRep (Just t, n) = VarE 'appTDM `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''AppSelector `AppT` VarT clsVar `AppT` t))) 
-                                             `AppE` VarE tokenName `AppE` VarE funName 
+  where mapArgRep (Just t, n) = VarE 'appTDM `AppE` (VarE 'undefined `SigE` (ConT ''FlagToken `AppT` (ConT ''AppSelector `AppT` VarT clsVar `AppT` t)))
+                                             `AppE` VarE tokenName `AppE` VarE funName
                                              `AppE` (VarE 'descendM_ `AppE` VarE tokenName `AppE` VarE funName) `AppE` VarE n
         mapArgRep (Nothing, n) = VarE 'return `AppE` VarE n
 
@@ -237,9 +235,9 @@ 
 -- | 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 
+generateAppAutoClause clsVar headType _ (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"
@@ -248,9 +246,9 @@ 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))) 
+  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
 
@@ -258,8 +256,8 @@ 
 -- | 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)] 
+generateAppAutoMClause clsVar headType _ (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)) )) []
@@ -268,15 +266,15 @@         funName = mkName "f"
 
 generateAutoRecombineMExpr :: Name -> Name -> Name -> Name -> [(Maybe Type, Name)] -> Exp
-generateAutoRecombineMExpr _ conName tokenName funName []
+generateAutoRecombineMExpr _ conName _ _ []
   = 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)) 
+  = 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))) 
+  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
 
@@ -290,13 +288,13 @@ 
 -- | Extracts the necessary information from a constructor.
 getConRep :: PrimitiveMarkers -> Con -> ConRep
-getConRep primitives (NormalC n args) 
+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) 
+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)) 
+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
         ])