module Database.HDBC.SqlValue.List.Derive (deriveSqlValueList)
where
import Language.Haskell.TH.Syntax
deriveSqlValueList :: Name -> Q [Dec]
deriveSqlValueList conTy = do
(conD, argn) <- isPlain conTy
deriveSqlValueList' conTy conD argn
isPlain :: Name -> Q (Name, Int)
isPlain conTy = do
info <- reify conTy
case info of
TyConI (DataD _ _ _ [con] _) -> return (convCon con)
TyConI (NewtypeD _ _ _ con _) -> return (convCon con)
_ -> error "deriveSqlValueList: Invalid type provided. The type must be a data with a single constructor or a newtype."
where convCon (NormalC name sts ) = (name, length sts)
convCon (RecC name vsts) = (name, length vsts)
deriveSqlValueList' conTy conD argn = do
decs <- sqlValueListDec (conTy, conD, argn)
return [InstanceD [] ((ConT (mkName "SqlValueList")) `AppT` ConT conTy) decs]
sqlValueListDec :: (Name, Name, Int)-> Q [Dec]
sqlValueListDec (conTy, conD, argn) = return $
[ _fun (mkName "toSqlList")
(x_conPat conD argn)
(x_mapListExp (mkName "toSql") argn)
, _fun (mkName "fromSqlList")
(x_listPat argn)
(x_mapConExp conD (mkName "fromSql") argn)
]
_fun :: Name -> Pat -> Exp -> Dec
_fun nm pat e = FunD nm [ Clause [pat] (NormalB e) []]
x_conPat :: Name -> Int -> Pat
x_conPat con n = ConP con (map VarP (x_args n))
x_listPat :: Int -> Pat
x_listPat n = ListP $ map VarP (x_args n)
x_mapListExp :: Name -> Int -> Exp
x_mapListExp f n = ListE $ map (\t -> VarE f `AppE` VarE t) (x_args n)
x_mapConExp ::Name -> Name -> Int -> Exp
x_mapConExp conD f n = foldl AppE (ConE conD) (map (\x -> VarE f `AppE` VarE x) (x_args n))
x_args :: Int -> [Name]
x_args n = [mkName ("x" ++ show i) | i <- [1..n]]