module Database.YeshQL.SqlRow.TH
where
import Database.YeshQL.SqlRow.Class
import Database.HDBC (fromSql, toSql)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.Generics.SYB.WithClass.Derive (typeInfo)
makeSqlRow :: Name -> Q [Dec]
makeSqlRow entityName = do
(TyConI d) <- reify entityName
(typeName, _, constructors) <- typeInfo d
(constructorName, fieldNames, fieldTypes) <-
case constructors of
[(constructorName, _, Just fieldNames, fieldTypes)] ->
return (constructorName, fieldNames, fieldTypes)
_ -> fail "Unsuitable type for deriving SqlRow"
[d|
instance ToSqlRow $(conT typeName) where
toSqlRow entity =
$(listE $ map (toSqlRowField 'entity) fieldNames)
instance FromSqlRow $(conT typeName) where
parseSqlRow = Parser $ \case
$(foldr
(\x xs -> infixP x '(:) xs)
(varP $ mkName "remaining")
(map fromSqlPatternItem fieldNames)
) ->
return
( $(foldl1 appE $
conE constructorName : map fromSqlPatternArg fieldNames)
, remaining
)
_ -> fail $ "Invalid SQL for " ++ $(litE . stringL . nameBase $ typeName) |]
where
toSqlRowField :: Name -> Name -> ExpQ
toSqlRowField entityName fieldName =
appE [|toSql|] $ appE (varE fieldName) (varE entityName)
fromSqlPatternItem :: Name -> PatQ
fromSqlPatternItem fieldName =
varP (mkName $ "sql_" ++ nameBase fieldName)
fromSqlPatternArg :: Name -> ExpQ
fromSqlPatternArg fieldName =
appE
(varE (mkName "fromSql"))
(varE (mkName $ "sql_" ++ nameBase fieldName))