{-# 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.Maybe (catMaybes)
import Control.Monad (guard, liftM, )
-- |@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 = x -- 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 })
--
deriveAccessors :: Name -> Q [Dec]
deriveAccessors n = nameDeriveAccessors n transformName
where
transformName s = do
guard $ not (null s)
guard $ last s == '_'
return $ init s
-- |@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
TyConI (DataD _ _name _ cons _) <- reify t
liftM concat $ mapM makeAccs cons
where
makeAccs :: Con -> Q [Dec]
makeAccs (RecC _ vars) =
liftM catMaybes $ mapM (\ (name,_,_) -> makeAccFromName name) vars
makeAccs (ForallC _ _ c) = makeAccs c
makeAccs _ = return []
transformName :: Name -> Maybe Name
transformName (Name occ f) = do
n <- namer (occString occ)
return $ Name (mkOccName n) f
makeAccFromName :: Name -> Q (Maybe Dec)
makeAccFromName name = do
case transformName name of
Nothing -> return Nothing
Just n -> liftM Just $ makeAcc name n
-- haddock doesn't grok TH
#ifndef __HADDOCK__
makeAcc :: Name -> Name -> Q Dec
makeAcc name accName = do
body <- [|
Accessor.fromSetGet
( \x s ->
$( return $ RecUpdE (VarE 's) [(name, VarE 'x)] ) )
( $( return $ VarE name ) )
|]
return $ ValD (VarP accName) (NormalB body) []
#endif