diff --git a/data-accessor-template.cabal b/data-accessor-template.cabal --- a/data-accessor-template.cabal +++ b/data-accessor-template.cabal @@ -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 , Henning Thielemann +Author: Luke Palmer , + Henning Thielemann Maintainer: Henning Thielemann 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 diff --git a/src-2.11/Data/Accessor/Template.hs b/src-2.11/Data/Accessor/Template.hs new file mode 100644 --- /dev/null +++ b/src-2.11/Data/Accessor/Template.hs @@ -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 diff --git a/src-2.2/Data/Accessor/Template.hs b/src-2.2/Data/Accessor/Template.hs new file mode 100644 --- /dev/null +++ b/src-2.2/Data/Accessor/Template.hs @@ -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 diff --git a/src-2.4/Data/Accessor/Template.hs b/src-2.4/Data/Accessor/Template.hs new file mode 100644 --- /dev/null +++ b/src-2.4/Data/Accessor/Template.hs @@ -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 diff --git a/src-3/Data/Accessor/Template.hs b/src-3/Data/Accessor/Template.hs deleted file mode 100644 --- a/src-3/Data/Accessor/Template.hs +++ /dev/null @@ -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 diff --git a/src-5/Data/Accessor/Template.hs b/src-5/Data/Accessor/Template.hs deleted file mode 100644 --- a/src-5/Data/Accessor/Template.hs +++ /dev/null @@ -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 diff --git a/src/Data/Accessor/Template/Example.hs b/src/Data/Accessor/Template/Example.hs --- a/src/Data/Accessor/Template/Example.hs +++ b/src/Data/Accessor/Template/Example.hs @@ -8,3 +8,12 @@ Qux { x_ :: a } $( AT.deriveAccessors ''Foo ) + + +data HigherKind tycon = + HigherKind { + y_ :: tycon Int, + z_ :: tycon Char + } + +$( AT.deriveAccessors ''HigherKind )