module Database.Relational.Query.BaseTH (
defineProductConstructorInstance,
defineTupleProductConstructor,
defineTupleShowConstantInstance,
defineTuplePi,
) where
import Control.Applicative ((<$>))
import Data.List (foldl')
import Language.Haskell.TH
(Q, Name, mkName, tupleDataName, normalB, classP, varP,
TypeQ, forallT, arrowT, varT, tupleT, appT,
Dec, sigD, valD, instanceD, ExpQ, conE,
TyVarBndr (PlainTV), )
import Database.Record.Persistable
(PersistableWidth, persistableWidth,
PersistableRecordWidth, runPersistableRecordWidth)
import Database.Relational.Query.ProjectableClass
(ProductConstructor (..), ShowConstantTermsSQL (..), )
import Database.Relational.Query.Pi.Unsafe (Pi, definePi)
defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]
defineProductConstructorInstance recTypeQ recData colTypes =
[d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where
productConstructor = $(recData)
|]
tupleN :: Int -> (([Name], [TypeQ]), TypeQ)
tupleN n = ((ns, vs), foldl' appT (tupleT n) vs)
where
ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ]
vs = map varT ns
defineTupleProductConstructor :: Int -> Q [Dec]
defineTupleProductConstructor n = do
let ((_, vs), tty) = tupleN n
defineProductConstructorInstance tty (conE $ tupleDataName n) vs
defineTupleShowConstantInstance :: Int -> Q [Dec]
defineTupleShowConstantInstance n = do
let ((_, vs), tty) = tupleN n
(:[]) <$> instanceD
(mapM (classP ''ShowConstantTermsSQL . (:[])) vs)
[t| ShowConstantTermsSQL $tty |]
[]
tuplePi :: Int -> Int -> Q [Dec]
tuplePi n i = do
let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"
((ns, vs), tty) = tupleN n
sig <- sigD selN $
forallT (map PlainTV ns)
(mapM (classP ''PersistableWidth . (:[])) vs)
[t| Pi $tty $(vs !! i) |]
val <- valD (varP selN)
(normalB [| definePi $(foldl'
(\e t -> [| $e + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |])
[| 0 :: Int |] $ take i vs) |])
[]
return [sig, val]
defineTuplePi :: Int -> Q [Dec]
defineTuplePi n =
concat <$> mapM (tuplePi n) [0 .. n 1]