{-|

 /Example Use:/

@
data Record = R {who :: String, age :: Int} deriving (Show, Eq)
deriveSqlValueList ''Record
@
-}
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]]