module Data.Accessor.Template (
nameDeriveAccessors, deriveAccessors,
) where
import qualified Data.Accessor.Basic as Accessor
import Language.Haskell.TH.Syntax
import Data.Maybe (catMaybes)
import Control.Monad (guard, liftM, when)
deriveAccessors :: Name -> Q [Dec]
deriveAccessors n = nameDeriveAccessors n transformName
where
transformName s = do
guard $ not (null s)
guard $ last s == '_'
return $ init s
nameDeriveAccessors :: Name -> (String -> Maybe String) -> Q [Dec]
nameDeriveAccessors t namer = do
info <- reify t
reified <- case info of
TyConI dec -> return dec
_ -> fail errmsg
cons <- case reified of
DataD _ _ _ cons' _ -> return cons'
NewtypeD _ _ _ con' _ -> return [con']
_ -> fail errmsg
decs <- liftM concat $ mapM makeAccs 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 :: 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
#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