1{-# LANGUAGE TemplateHaskell, CPP #-} 2 3{- | 4This module provides an automatic Template Haskell 5routine to scour data type definitions and generate 6accessor objects for them automatically. 7-} 8module Data.Accessor.Template ( 9 nameDeriveAccessors, deriveAccessors, 10 ) where 11 12import qualified Data.Accessor.Basic as Accessor 13 14import Language.Haskell.TH.Syntax 15 -- (Q, Exp(VarE), Pat(VarP), Dec(ValD), Name(Name), mkOccName, occString, reify, ) 16 17import qualified Data.Traversable as Trav 18import Data.List (nub, ) 19import Data.List.HT (viewR, ) 20import Data.Maybe (catMaybes, ) 21import Control.Monad (liftM, when, ) 22 23 24 25-- |@deriveAccessors n@ where @n@ is the name of a data type 26-- declared with @data@ looks through all the declared fields 27-- of the data type, and for each field ending in an underscore 28-- generates an accessor of the same name without the underscore. 29-- 30-- It is "nameDeriveAccessors" n f where @f@ satisfies 31-- 32-- > f (s ++ "_") = Just s 33-- > f x = Nothing -- otherwise 34-- 35-- For example, given the data type: 36-- 37-- > data Score = Score { p1Score_ :: Int 38-- > , p2Score_ :: Int 39-- > , rounds :: Int 40-- > } 41-- 42-- @deriveAccessors@ will generate the following objects: 43-- 44-- > p1Score :: Accessor Score Int 45-- > p1Score = Accessor p1Score_ (\x s -> s { p1Score_ = x }) 46-- > p2Score :: Accessor Score Int 47-- > p2Score = Accessor p2Score_ (\x s -> s { p2Score_ = x }) 48-- 49-- It is used with Template Haskell syntax like: 50-- 51-- > $( deriveAccessors ''TypeName ) 52-- 53-- And will generate accessors when TypeName was declared 54-- using @data@ or @newtype@. 55deriveAccessors :: Name -> Q [Dec] 56deriveAccessors n = nameDeriveAccessors n stripUnderscore 57 58stripUnderscore :: String -> Maybe String 59stripUnderscore s = do 60 (stem,'_') <- viewR s 61 return stem 62 63namedFields :: Con -> [VarStrictType] 64namedFields (RecC _ fs) = fs 65namedFields (ForallC _ _ c) = namedFields c 66namedFields _ = [] 67 68-- |@nameDeriveAccessors n f@ where @n@ is the name of a data type 69-- declared with @data@ and @f@ is a function from names of fields 70-- in that data type to the name of the corresponding accessor. If 71-- @f@ returns @Nothing@, then no accessor is generated for that 72-- field. 73nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec] 74nameDeriveAccessors t namer = do 75 info <- reify t 76 reified <- case info of 77 TyConI dec -> return dec 78 _ -> fail errmsg 79 (params, cons) <- case reified of 80 DataD _ _ params _ cons' _ -> return (params, cons') 81 NewtypeD _ _ params _ con' _ -> return (params, [con']) 82 _ -> fail errmsg 83 decs <- makeAccs params . nub $ concatMap namedFields cons 84 when (null decs) $ qReport False nodefmsg 85 return decs 86 87 where 88 89 errmsg = "Cannot derive accessors for name " ++ show t ++ " because" 90 ++ "\n it is not a type declared with 'data' or 'newtype'" 91 ++ "\n Did you remember to double-tick the type as in" 92 ++ "\n $(deriveAccessors ''TheType)?" 93 94 nodefmsg = "Warning: No accessors generated from the name " ++ show t 95 ++ "\n If you are using deriveAccessors rather than" 96 ++ "\n nameDeriveAccessors, remember accessors are" 97 ++ "\n only generated for fields ending with an underscore" 98 99 makeAccs :: [TyVarBndr] -> [VarStrictType] -> Q [Dec] 100 makeAccs params vars = 101 liftM (concat . catMaybes) $ 102 mapM (\ (name,_,ftype) -> makeAccFromName name params ftype) vars 103 104 transformName :: Name -> Maybe Name 105 transformName (Name occ f) = do 106 n <- namer (occString occ) 107 return $ Name (mkOccName n) f 108 109 makeAccFromName :: Name -> [TyVarBndr] -> Type -> Q (Maybe [Dec]) 110 makeAccFromName name params ftype = 111 Trav.mapM (makeAcc name params ftype) $ transformName name 112 113 -- haddock doesn't grok TH 114#ifndef __HADDOCK__ 115 116 makeAcc ::Name -> [TyVarBndr] -> Type -> Name -> Q [Dec] 117 makeAcc name params ftype accName = do 118 let params' = map (\x -> case x of (PlainTV n) -> n; (KindedTV n _) -> n) params 119 let appliedT = foldl AppT (ConT t) (map VarT params') 120 body <- [| 121 Accessor.fromSetGet 122 ( \x s -> 123 $( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) ) 124 ( $( return $ VarE name ) ) 125 |] 126 return 127 [ SigD accName (ForallT (map PlainTV params') 128 [] (AppT (AppT (ConT ''Accessor.T) appliedT) ftype)) 129 , ValD (VarP accName) (NormalB body) [] 130 ] 131 132#endif 133