module Database.PostgreSQL.Query.TH.Row
( deriveFromRow
, deriveToRow
) where
import Database.PostgreSQL.Query.TH.Common
import Database.PostgreSQL.Simple.FromRow ( FromRow(..), field )
import Database.PostgreSQL.Simple.ToRow ( ToRow(..) )
import Language.Haskell.TH
deriveFromRow :: Name -> Q [Dec]
deriveFromRow :: Name -> Q [Dec]
deriveFromRow Name
t = do
Con
con <- Info -> [Con]
dataConstructors (Info -> [Con]) -> Q Info -> Q [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
t Q [Con] -> ([Con] -> Q Con) -> Q Con
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[Con
a] -> Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
[Con]
x -> String -> Q Con
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Con) -> String -> Q Con
forall a b. (a -> b) -> a -> b
$ String
"expected exactly 1 data constructor, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" got"
Name
cname <- Con -> Q Name
forall (m :: * -> *). Monad m => Con -> m Name
cName Con
con
Int
cargs <- Con -> Q Int
forall (m :: * -> *). Monad m => Con -> m Int
cArgs Con
con
[d|instance FromRow $(return $ ConT t) where
fromRow = $(fieldsQ cname cargs)|]
where
fieldsQ :: Name -> t -> Q Exp
fieldsQ Name
cname t
cargs = do
Exp
fld <- [| field |]
Exp
fmp <- [| (<$>) |]
Exp
fap <- [| (<*>) |]
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
UInfixE (Name -> Exp
ConE Name
cname) Exp
fmp (t -> Exp -> Exp -> Exp
forall t. (Eq t, Num t) => t -> Exp -> Exp -> Exp
fapChain t
cargs Exp
fld Exp
fap)
fapChain :: t -> Exp -> Exp -> Exp
fapChain t
0 Exp
_ Exp
_ = String -> Exp
forall a. HasCallStack => String -> a
error String
"there must be at least 1 field in constructor"
fapChain t
1 Exp
fld Exp
_ = Exp
fld
fapChain t
n Exp
fld Exp
fap = Exp -> Exp -> Exp -> Exp
UInfixE Exp
fld Exp
fap (t -> Exp -> Exp -> Exp
fapChain (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Exp
fld Exp
fap)
deriveToRow :: Name -> Q [Dec]
deriveToRow :: Name -> Q [Dec]
deriveToRow Name
t = do
Con
con <- Info -> [Con]
dataConstructors (Info -> [Con]) -> Q Info -> Q [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify Name
t Q [Con] -> ([Con] -> Q Con) -> Q Con
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[Con
a] -> Con -> Q Con
forall (m :: * -> *) a. Monad m => a -> m a
return Con
a
[Con]
x -> String -> Q Con
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Con) -> String -> Q Con
forall a b. (a -> b) -> a -> b
$ String
"expected exactly 1 data constructor, but " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Con] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Con]
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" got"
Name
cname <- Con -> Q Name
forall (m :: * -> *). Monad m => Con -> m Name
cName Con
con
Int
cargs <- Con -> Q Int
forall (m :: * -> *). Monad m => Con -> m Int
cArgs Con
con
[Name]
cvars <- [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
([Q Name] -> Q [Name]) -> [Q Name] -> Q [Name]
forall a b. (a -> b) -> a -> b
$ Int -> Q Name -> [Q Name]
forall a. Int -> a -> [a]
replicate Int
cargs
(Q Name -> [Q Name]) -> Q Name -> [Q Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"a"
[d|instance ToRow $(return $ ConT t) where
#if MIN_VERSION_template_haskell(2,18,0)
toRow $(return $ ConP cname [] $ map VarP cvars) = $(toFields cvars)|]
#else
toRow $(return $ ConP cname $ map VarP cvars) = $(toFields cvars)|]
#endif
where
toFields :: [Name] -> Q Exp
toFields [Name]
v = do
Name
tof <- String -> Q Name
lookupVNameErr String
"toField"
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
e -> Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
tof) (Name -> Exp
VarE Name
e)) [Name]
v