packages feed

data-accessor-template 0.2.1.3 → 0.2.1.16

raw patch · 7 files changed

Files

data-accessor-template.cabal view
@@ -1,40 +1,80 @@ Name:             data-accessor-template-Version:          0.2.1.3+Version:          0.2.1.16 License:          BSD3 License-File:     LICENSE-Author:           Luke Palmer <lrpalmer@gmail.com>, Henning Thielemann <haskell@henning-thielemann.de>+Author:           Luke Palmer <lrpalmer@gmail.com>,+                  Henning Thielemann <haskell@henning-thielemann.de> Maintainer:       Henning Thielemann <haskell@henning-thielemann.de> Homepage:         http://www.haskell.org/haskellwiki/Record_access-Package-URL:      http://code.haskell.org/data-accessor/ Category:         Data+-- Default-Language: Haskell98+Cabal-Version:    >=1.6+Build-Type:       Simple+Tested-With:      GHC==6.8.2, GHC==6.10.4, GHC==6.12.3+Tested-With:      GHC==7.0.1, GHC==7.2.2, GHC==7.4.2, GHC==7.6.1, GHC==7.8.4+Tested-With:      GHC==8.0.1 Synopsis:         Utilities for accessing and manipulating fields of records Description:   Automate generation of @Accessor@'s of the @data-accessor@ package   by Template Haskell functions.-Build-Type:       Simple-Tested-With:      GHC==6.8.2-Cabal-Version:    >=1.2  Extra-Source-Files:-  src-3/Data/Accessor/Template.hs-  src-5/Data/Accessor/Template.hs+  src-2.2/Data/Accessor/Template.hs+  src-2.4/Data/Accessor/Template.hs+  src-2.11/Data/Accessor/Template.hs  Flag template_2_4-  description: Adapt to TemplateHaskell version of GHC-6.12-  default: False+  Description: Adapt to Template Haskell 2.4 and later, this is ignored for GHC+  Default: False +Flag template_2_11+  Description: Adapt to Template Haskell 2.11 and later, this is ignored for GHC+  Default: False++Source-Repository this+  Tag:         0.2.1.16+  Type:        darcs+  Location:    http://code.haskell.org/data-accessor/template/++Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/data-accessor/template/+ Library   Build-Depends:     data-accessor >=0.1 && <0.4,     utility-ht >=0.0.1 && <0.1,-    base >=1.0 && <6+    base >=1.0 && <5 -  If flag(template_2_4)-    Hs-Source-Dirs: src-5-    Build-Depends:  template-haskell >=2.4 && <2.5+  If impl(ghc)+    If impl(ghc >= 8.0)+      Hs-Source-Dirs: src-2.11+      Build-Depends:  template-haskell >=2.11 && <2.15+    Else+      If impl(ghc >= 6.12)+        Hs-Source-Dirs: src-2.4+        Build-Depends:  template-haskell >=2.4 && <2.11+      Else+        Hs-Source-Dirs: src-2.2+        Build-Depends:  template-haskell >=2.2 && <2.4++  -- This is for TemplateHaskell implementations other than that of GHC.+  -- However, currently there are no such implementations.+  -- This is the cleaner way to express the dependency,+  -- however cabal-install's automated flag and package dependency resolution fails+  -- either for GHC-6.10 or GHC-6.12+  -- depending on the default value of the template_2_4 flag.   Else-    Hs-Source-Dirs: src-3-    Build-Depends:  template-haskell >=2.2 && <2.4+    If flag(template_2_11)+      Hs-Source-Dirs: src-2.11+      Build-Depends:  template-haskell >=2.11 && <2.15+    Else+      If flag(template_2_4)+        Hs-Source-Dirs: src-2.4+        Build-Depends:  template-haskell >=2.4 && <2.11+      Else+        Hs-Source-Dirs: src-2.2+        Build-Depends:  template-haskell >=2.2 && <2.4    Exposed-Modules:     Data.Accessor.Template
+ src-2.11/Data/Accessor/Template.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TemplateHaskell, CPP #-}++{- |+This module provides an automatic Template Haskell+routine to scour data type definitions and generate+accessor objects for them automatically.+-}+module Data.Accessor.Template (+   nameDeriveAccessors, deriveAccessors,+   ) where++import qualified Data.Accessor.Basic as Accessor++import Language.Haskell.TH.Syntax+  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )++import qualified Data.Traversable as Trav+import Data.List (nub, )+import Data.List.HT (viewR, )+import Data.Maybe (catMaybes, )+import Control.Monad (liftM, when, )++++-- |@deriveAccessors n@ where @n@ is the name of a data type+-- declared with @data@ looks through all the declared fields+-- of the data type, and for each field ending in an underscore+-- generates an accessor of the same name without the underscore.+--+-- It is "nameDeriveAccessors" n f where @f@ satisfies+--+-- > f (s ++ "_") = Just s+-- > f x = Nothing -- otherwise+--+-- For example, given the data type:+--+-- > data Score = Score { p1Score_ :: Int+-- > , p2Score_ :: Int+-- > , rounds :: Int+-- > }+--+-- @deriveAccessors@ will generate the following objects:+--+-- > p1Score :: Accessor Score Int+-- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })+-- > p2Score :: Accessor Score Int+-- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })+--+-- It is used with Template Haskell syntax like:+--+-- > $( deriveAccessors ''TypeName )+--+-- And will generate accessors when TypeName was declared+-- using @data@ or @newtype@.+deriveAccessors :: Name -> Q [Dec]+deriveAccessors n = nameDeriveAccessors n stripUnderscore++stripUnderscore :: String -> Maybe String+stripUnderscore s = do+    (stem,'_') <- viewR s+    return stem++namedFields :: Con -> [VarStrictType]+namedFields (RecC _ fs) = fs+namedFields (ForallC _ _ c) = namedFields c+namedFields _ = []++-- |@nameDeriveAccessors n f@ where @n@ is the name of a data type+-- declared with @data@ and @f@ is a function from names of fields+-- in that data type to the name of the corresponding accessor. If+-- @f@ returns @Nothing@, then no accessor is generated for that+-- field.+nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]+nameDeriveAccessors t namer = do+    info <- reify t+    reified <- case info of+                    TyConI dec -> return dec+                    _ -> fail errmsg+    (params, cons) <- case reified of+                 DataD _ _ params _ cons' _ -> return (params, cons')+                 NewtypeD _ _ params _ con' _ -> return (params, [con'])+                 _ -> fail errmsg+    decs <- makeAccs params . nub $ concatMap namedFields cons+    when (null decs) $ qReport False nodefmsg+    return decs++    where++    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"+          ++ "\n it is not a type declared with 'data' or 'newtype'"+          ++ "\n Did you remember to double-tick the type as in"+          ++ "\n $(deriveAccessors ''TheType)?"++    nodefmsg = "Warning: No accessors generated from the name " ++ show t+          ++ "\n If you are using deriveAccessors rather than"+          ++ "\n nameDeriveAccessors, remember accessors are"+          ++ "\n only generated for fields ending with an underscore"++    makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]+    makeAccs params vars =+        liftM (concat . catMaybes) $+        mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars++    transformName :: Name -> Maybe Name+    transformName (Name occ f) = do+        n <- namer (occString occ)+        return $ Name (mkOccName n) f++    makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec])+    makeAccFromName name params ftype =+        Trav.mapM (makeAcc name params ftype) $ transformName name++    -- haddock doesn't grok TH+#ifndef __HADDOCK__++    makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec]+    makeAcc name params ftype accName = do+        let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params+        let appliedT = foldl AppT (ConT t) (map VarT params')+        body <- [|+                 Accessor.fromSetGet+                    ( \x s ->+                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )+                    ( $( return $ VarE name ) )+                |]+        return+          [ SigD accName (ForallT (map PlainTV params')+               [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype))+          , ValD (VarP accName) (NormalB body) []+          ]++#endif
+ src-2.2/Data/Accessor/Template.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE TemplateHaskell, CPP #-}++{- |+This module provides an automatic Template Haskell+routine to scour data type definitions and generate+accessor objects for them automatically.+-}+module Data.Accessor.Template (+   nameDeriveAccessors, deriveAccessors,+   ) where++import qualified Data.Accessor.Basic as Accessor++import Language.Haskell.TH.Syntax+  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )++import Data.List (nub, )+import Data.List.HT (viewR, )+import Data.Maybe (catMaybes, )+import Control.Monad (liftM, when, )++++-- |@deriveAccessors n@ where @n@ is the name of a data type+-- declared with @data@ looks through all the declared fields+-- of the data type, and for each field ending in an underscore+-- generates an accessor of the same name without the underscore.+--+-- It is "nameDeriveAccessors" n f where @f@ satisfies+--+-- > f (s ++ "_") = Just s+-- > f x          = Nothing    -- otherwise+--+-- For example, given the data type:+--+-- > data Score = Score { p1Score_ :: Int+-- >                    , p2Score_ :: Int+-- >                    , rounds   :: Int+-- >                    }+--+-- @deriveAccessors@ will generate the following objects:+--+-- > p1Score :: Accessor Score Int+-- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })+-- > p2Score :: Accessor Score Int+-- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })+--+-- It is used with Template Haskell syntax like:+--+-- > $( deriveAccessors ''TypeName )+--+-- And will generate accessors when TypeName was declared+-- using @data@ or @newtype@.+deriveAccessors :: Name -> Q [Dec]+deriveAccessors n = nameDeriveAccessors n stripUnderscore++stripUnderscore :: String -> Maybe String+stripUnderscore s = do+    (stem,'_') <- viewR s+    return stem++namedFields :: Con -> [VarStrictType]+namedFields (RecC _ fs) = fs+namedFields (ForallC _ _ c) = namedFields c+namedFields _ = []++-- |@nameDeriveAccessors n f@ where @n@ is the name of a data type+-- declared with @data@ and @f@ is a function from names of fields+-- in that data type to the name of the corresponding accessor. If+-- @f@ returns @Nothing@, then no accessor is generated for that+-- field.+nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]+nameDeriveAccessors t namer = do+    info <- reify t+    reified <- case info of+                    TyConI dec -> return dec+                    _ -> fail errmsg+    (params, cons) <- case reified of+                 DataD _ _ params cons' _ -> return (params, cons')+                 NewtypeD _ _ params con' _ -> return (params, [con'])+                 _ -> fail errmsg++    decs <- makeAccs params . nub $ concatMap namedFields cons+    when (null decs) $ qReport False nodefmsg+    return decs++    where++    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"+          ++ "\n    it is not a type declared with 'data' or 'newtype'"+          ++ "\n    Did you remember to double-tick the type as in"+          ++ "\n      $(deriveAccessors ''TheType)?"++    nodefmsg = "Warning: No accessors generated from the name " ++ show t+          ++ "\n    If you are using deriveAccessors rather than"+          ++ "\n    nameDeriveAccessors, remember accessors are"+          ++ "\n    only generated for fields ending with an underscore"++    makeAccs :: [Name] -> [VarStrictType] -> Q [Dec]+    makeAccs params vars =+        liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars++    transformName :: Name -> Maybe Name+    transformName (Name occ f) = do+        n <- namer (occString occ)+        return $ Name (mkOccName n) f++    makeAccFromName :: Name -> [Name] -> Type -> Q (Maybe [Dec])+    makeAccFromName name params ftype =+        case transformName name of+            Nothing -> return Nothing+            Just n -> liftM Just $ makeAcc name params ftype n++    -- haddock doesn't grok TH+#ifndef __HADDOCK__++    makeAcc ::Name -> [Name] -> Type -> Name -> Q [Dec]+    makeAcc name params ftype accName = do+        let appliedT = foldl AppT (ConT t) (map VarT params)+        body <- [|+                 Accessor.fromSetGet+                    ( \x s ->+                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )+                    ( $( return $ VarE name ) )+                |]+        return+          [ SigD accName (ForallT params [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype))+          , ValD (VarP accName) (NormalB body) []+          ]++#endif
+ src-2.4/Data/Accessor/Template.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TemplateHaskell, CPP #-}++{- |+This module provides an automatic Template Haskell+routine to scour data type definitions and generate+accessor objects for them automatically.+-}+module Data.Accessor.Template (+   nameDeriveAccessors, deriveAccessors,+   ) where++import qualified Data.Accessor.Basic as Accessor++import Language.Haskell.TH.Syntax+  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )++import Data.List (nub, )+import Data.List.HT (viewR, )+import Data.Maybe (catMaybes, )+import Control.Monad (liftM, when, )++++-- |@deriveAccessors n@ where @n@ is the name of a data type+-- declared with @data@ looks through all the declared fields+-- of the data type, and for each field ending in an underscore+-- generates an accessor of the same name without the underscore.+--+-- It is "nameDeriveAccessors" n f where @f@ satisfies+--+-- > f (s ++ "_") = Just s+-- > f x = Nothing -- otherwise+--+-- For example, given the data type:+--+-- > data Score = Score { p1Score_ :: Int+-- > , p2Score_ :: Int+-- > , rounds :: Int+-- > }+--+-- @deriveAccessors@ will generate the following objects:+--+-- > p1Score :: Accessor Score Int+-- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })+-- > p2Score :: Accessor Score Int+-- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })+--+-- It is used with Template Haskell syntax like:+--+-- > $( deriveAccessors ''TypeName )+--+-- And will generate accessors when TypeName was declared+-- using @data@ or @newtype@.+deriveAccessors :: Name -> Q [Dec]+deriveAccessors n = nameDeriveAccessors n stripUnderscore++stripUnderscore :: String -> Maybe String+stripUnderscore s = do+    (stem,'_') <- viewR s+    return stem++namedFields :: Con -> [VarStrictType]+namedFields (RecC _ fs) = fs+namedFields (ForallC _ _ c) = namedFields c+namedFields _ = []++-- |@nameDeriveAccessors n f@ where @n@ is the name of a data type+-- declared with @data@ and @f@ is a function from names of fields+-- in that data type to the name of the corresponding accessor. If+-- @f@ returns @Nothing@, then no accessor is generated for that+-- field.+nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]+nameDeriveAccessors t namer = do+    info <- reify t+    reified <- case info of+                    TyConI dec -> return dec+                    _ -> fail errmsg+    (params, cons) <- case reified of+                 DataD _ _ params cons' _ -> return (params, cons')+                 NewtypeD _ _ params con' _ -> return (params, [con'])+                 _ -> fail errmsg+    decs <- makeAccs params . nub $ concatMap namedFields cons+    when (null decs) $ qReport False nodefmsg+    return decs++    where++    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"+          ++ "\n it is not a type declared with 'data' or 'newtype'"+          ++ "\n Did you remember to double-tick the type as in"+          ++ "\n $(deriveAccessors ''TheType)?"++    nodefmsg = "Warning: No accessors generated from the name " ++ show t+          ++ "\n If you are using deriveAccessors rather than"+          ++ "\n nameDeriveAccessors, remember accessors are"+          ++ "\n only generated for fields ending with an underscore"++    makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]+    makeAccs params vars =+        liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars++    transformName :: Name -> Maybe Name+    transformName (Name occ f) = do+        n <- namer (occString occ)+        return $ Name (mkOccName n) f++    makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec])+    makeAccFromName name params ftype =+        case transformName name of+            Nothing -> return Nothing+            Just n -> liftM Just $ makeAcc name params ftype n++    -- haddock doesn't grok TH+#ifndef __HADDOCK__++    makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec]+    makeAcc name params ftype accName = do+        let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params+        let appliedT = foldl AppT (ConT t) (map VarT params')+        body <- [|+                 Accessor.fromSetGet+                    ( \x s ->+                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )+                    ( $( return $ VarE name ) )+                |]+        return+          [ SigD accName (ForallT (map PlainTV params')+               [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype))+          , ValD (VarP accName) (NormalB body) []+          ]++#endif
− src-3/Data/Accessor/Template.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}--{- |-This module provides an automatic Template Haskell-routine to scour data type definitions and generate-accessor objects for them automatically.--}-module Data.Accessor.Template (-   nameDeriveAccessors, deriveAccessors,-   ) where--import qualified Data.Accessor.Basic as Accessor--import Language.Haskell.TH.Syntax-  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )--import Data.List (nub, )-import Data.List.HT (viewR, )-import Data.Maybe (catMaybes, )-import Control.Monad (liftM, when, )------ |@deriveAccessors n@ where @n@ is the name of a data type--- declared with @data@ looks through all the declared fields--- of the data type, and for each field ending in an underscore--- generates an accessor of the same name without the underscore.------ It is "nameDeriveAccessors" n f where @f@ satisfies------ > f (s ++ "_") = Just s--- > f x          = Nothing    -- otherwise------ For example, given the data type:------ > data Score = Score { p1Score_ :: Int--- >                    , p2Score_ :: Int--- >                    , rounds   :: Int--- >                    }------ @deriveAccessors@ will generate the following objects:------ > p1Score :: Accessor Score Int--- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })--- > p2Score :: Accessor Score Int--- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })------ It is used with Template Haskell syntax like:------ > $( deriveAccessors ''TypeName )------ And will generate accessors when TypeName was declared--- using @data@ or @newtype@.-deriveAccessors :: Name -> Q [Dec]-deriveAccessors n = nameDeriveAccessors n stripUnderscore--stripUnderscore :: String -> Maybe String-stripUnderscore s = do-    (stem,'_') <- viewR s-    return stem--namedFields :: Con -> [VarStrictType]-namedFields (RecC _ fs) = fs-namedFields (ForallC _ _ c) = namedFields c-namedFields _ = []---- |@nameDeriveAccessors n f@ where @n@ is the name of a data type--- declared with @data@ and @f@ is a function from names of fields--- in that data type to the name of the corresponding accessor. If--- @f@ returns @Nothing@, then no accessor is generated for that--- field.-nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]-nameDeriveAccessors t namer = do-    info <- reify t-    reified <- case info of-                    TyConI dec -> return dec-                    _ -> fail errmsg-    (params, cons) <- case reified of-                 DataD _ _ params cons' _ -> return (params, cons')-                 NewtypeD _ _ params con' _ -> return (params, [con'])-                 _ -> fail errmsg--    decs <- makeAccs params . nub $ concatMap namedFields cons-    when (null decs) $ qReport False nodefmsg-    return decs--    where--    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"-          ++ "\n    it is not a type declared with 'data' or 'newtype'"-          ++ "\n    Did you remember to double-tick the type as in"-          ++ "\n      $(deriveAccessors ''TheType)?"--    nodefmsg = "Warning: No accessors generated from the name " ++ show t-          ++ "\n    If you are using deriveAccessors rather than"-          ++ "\n    nameDeriveAccessors, remember accessors are"-          ++ "\n    only generated for fields ending with an underscore"--    makeAccs :: [Name] -> [VarStrictType] -> Q [Dec]-    makeAccs params vars =-        liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars--    transformName :: Name -> Maybe Name-    transformName (Name occ f) = do-        n <- namer (occString occ)-        return $ Name (mkOccName n) f--    makeAccFromName :: Name -> [Name] -> Type -> Q (Maybe [Dec])-    makeAccFromName name params ftype =-        case transformName name of-            Nothing -> return Nothing-            Just n -> liftM Just $ makeAcc name params ftype n--    -- haddock doesn't grok TH-#ifndef __HADDOCK__--    makeAcc ::Name -> [Name] -> Type -> Name -> Q [Dec]-    makeAcc name params ftype accName = do-        let appliedT = foldl AppT (ConT t) (map VarT params)-        body <- [|-                 Accessor.fromSetGet-                    ( \x s ->-                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )-                    ( $( return $ VarE name ) )-                |]-        return-          [ SigD accName (ForallT params [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype))-          , ValD (VarP accName) (NormalB body) []-          ]--#endif
− src-5/Data/Accessor/Template.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}--{- |-This module provides an automatic Template Haskell-routine to scour data type definitions and generate-accessor objects for them automatically.--}-module Data.Accessor.Template (-   nameDeriveAccessors, deriveAccessors,-   ) where--import qualified Data.Accessor.Basic as Accessor--import Language.Haskell.TH.Syntax-  -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, )--import Data.List (nub, )-import Data.List.HT (viewR, )-import Data.Maybe (catMaybes, )-import Control.Monad (liftM, when, )------ |@deriveAccessors n@ where @n@ is the name of a data type--- declared with @data@ looks through all the declared fields--- of the data type, and for each field ending in an underscore--- generates an accessor of the same name without the underscore.------ It is "nameDeriveAccessors" n f where @f@ satisfies------ > f (s ++ "_") = Just s--- > f x = Nothing -- otherwise------ For example, given the data type:------ > data Score = Score { p1Score_ :: Int--- > , p2Score_ :: Int--- > , rounds :: Int--- > }------ @deriveAccessors@ will generate the following objects:------ > p1Score :: Accessor Score Int--- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x })--- > p2Score :: Accessor Score Int--- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x })------ It is used with Template Haskell syntax like:------ > $( deriveAccessors ''TypeName )------ And will generate accessors when TypeName was declared--- using @data@ or @newtype@.-deriveAccessors :: Name -> Q [Dec]-deriveAccessors n = nameDeriveAccessors n stripUnderscore--stripUnderscore :: String -> Maybe String-stripUnderscore s = do-    (stem,'_') <- viewR s-    return stem--namedFields :: Con -> [VarStrictType]-namedFields (RecC _ fs) = fs-namedFields (ForallC _ _ c) = namedFields c-namedFields _ = []---- |@nameDeriveAccessors n f@ where @n@ is the name of a data type--- declared with @data@ and @f@ is a function from names of fields--- in that data type to the name of the corresponding accessor. If--- @f@ returns @Nothing@, then no accessor is generated for that--- field.-nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]-nameDeriveAccessors t namer = do-    info <- reify t-    reified <- case info of-                    TyConI dec -> return dec-                    _ -> fail errmsg-    (params, cons) <- case reified of-                 DataD _ _ params cons' _ -> return (params, cons')-                 NewtypeD _ _ params con' _ -> return (params, [con'])-                 _ -> fail errmsg-    decs <- makeAccs params . nub $ concatMap namedFields cons-    when (null decs) $ qReport False nodefmsg-    return decs--    where--    errmsg = "Cannot derive accessors for name " ++ show t ++ " because"-          ++ "\n it is not a type declared with 'data' or 'newtype'"-          ++ "\n Did you remember to double-tick the type as in"-          ++ "\n $(deriveAccessors ''TheType)?"--    nodefmsg = "Warning: No accessors generated from the name " ++ show t-          ++ "\n If you are using deriveAccessors rather than"-          ++ "\n nameDeriveAccessors, remember accessors are"-          ++ "\n only generated for fields ending with an underscore"--    makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec]-    makeAccs params vars =-        liftM (concat . catMaybes) $ mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars--    transformName :: Name -> Maybe Name-    transformName (Name occ f) = do-        n <- namer (occString occ)-        return $ Name (mkOccName n) f--    makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec])-    makeAccFromName name params ftype =-        case transformName name of-            Nothing -> return Nothing-            Just n -> liftM Just $ makeAcc name params ftype n--    -- haddock doesn't grok TH-#ifndef __HADDOCK__--    makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec]-    makeAcc name params ftype accName = do-        let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params-        let appliedT = foldl AppT (ConT t) (map VarT params')-        body <- [|-                 Accessor.fromSetGet-                    ( \x s ->-                        $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )-                    ( $( return $ VarE name ) )-                |]-        return-          [ SigD accName (ForallT params [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype))-          , ValD (VarP accName) (NormalB body) []-          ]--#endif
src/Data/Accessor/Template/Example.hs view
@@ -8,3 +8,12 @@    Qux { x_ :: a }  $( AT.deriveAccessors ''Foo )+++data HigherKind tycon =+   HigherKind {+      y_ :: tycon Int,+      z_ :: tycon Char+   }++$( AT.deriveAccessors ''HigherKind )