extractFields.hs

{-# LANGUAGE TemplateHaskell #-}
module Macros where
import Language.Haskell.TH
import Control.Monad

extractFields :: Name -> Q [Dec]
extractFields datName = do
    (VarI name tp dec fixty) <- reify datName
    let mytype = getMotherTypeName tp
    (TyConI dec) <- reify mytype
    cons <- case dec of
      (DataD _ _ _ cons _) -> return cons
      (TySynD _ _ ty) -> do
        (TyConI (DataD _ _ _ cons _)) <- reify $ getMotherTypeName ty
        return cons
    liftM concat $ mapM procCon cons
  where
    procCon :: Con -> Q [Dec]
    procCon (RecC _ dic) = mapM (\(name, _, _) -> valD (varP $ mkName $ nameBase name) (normalB $ appE (varE name) (varE datName)) []) dic
    procCon _ = return []


getMotherTypeName :: Type -> Name
getMotherTypeName (AppT a b) = getMotherTypeName a
getMotherTypeName (ForallT _ _ tp) = getMotherTypeName tp
getMotherTypeName (VarT n) = n
getMotherTypeName (ConT n) = n