khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2024-12-03 03:52:10 +03:00
Code Issues Projects Releases Wiki Activity

relational-query: add ProductConstrustor instance template of tuple type.

Browse Source
This commit is contained in:
Kei Hibino 2017-03-28 11:48:49 +09:00
parent 872d09c58d
commit f80e529096
1 changed files with 19 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
relational-query/src/Database/Relational/Query/Internal/TH.hs
View File

@ -3,16 +3,16 @@
module Database.Relational.Query.Internal.TH ( module Database.Relational.Query.Internal.TH (
defineProductConstructorInstance, defineProductConstructorInstance,
defineTupleProductConstructor,
defineTuplePi, defineTuplePi,
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.List (foldl') import Data.List (foldl')
import Language.Haskell.TH import Language.Haskell.TH
(Q, mkName, normalB, classP, varP, (Q, Name, mkName, tupleDataName, normalB, classP, varP,
Exp, TypeQ, forallT, arrowT, varT, tupleT, appT,
Type, forallT, varT, tupleT, appT, arrowT, Dec, sigD, valD, ExpQ, conE,
Dec, sigD, valD,
TyVarBndr (PlainTV), ) TyVarBndr (PlainTV), )
import Database.Record.Persistable import Database.Record.Persistable
(PersistableWidth, persistableWidth, (PersistableWidth, persistableWidth,
@ -24,22 +24,32 @@ import Database.Relational.Query.Pi.Unsafe (Pi, definePi)
-- | Make template for 'ProductConstructor' instance. -- | Make template for 'ProductConstructor' instance.
defineProductConstructorInstance :: Q Type -> Q Exp -> [Q Type] -> Q [Dec] defineProductConstructorInstance :: TypeQ -> ExpQ -> [TypeQ] -> Q [Dec]
defineProductConstructorInstance recTypeQ recData colTypes = defineProductConstructorInstance recTypeQ recData colTypes =
[d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) recTypeQ colTypes) where
productConstructor = $(recData) productConstructor = $(recData)
|] |]
-- | xxx 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
-- | Make template of ProductConstructor instance of tuple type.
defineTupleProductConstructor :: Int -> Q [Dec]
defineTupleProductConstructor n = do
let ((_, vs), tty) = tupleN n
defineProductConstructorInstance tty (conE $ tupleDataName n) vs
tuplePi :: Int -> Int -> Q [Dec] tuplePi :: Int -> Int -> Q [Dec]
tuplePi n i = do tuplePi n i = do
let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'" let selN = mkName $ "tuplePi" ++ show n ++ "_" ++ show i ++ "'"
ns = [ mkName $ "a" ++ show j | j <- [1 .. n] ] ((ns, vs), tty) = tupleN n
vs = map varT ns
sig <- sigD selN $ sig <- sigD selN $
forallT (map PlainTV ns) forallT (map PlainTV ns)
(mapM (classP ''PersistableWidth . (:[])) vs) (mapM (classP ''PersistableWidth . (:[])) vs)
[t| Pi $(foldl' appT (tupleT n) vs) $(vs !! i) |] [t| Pi $tty $(vs !! i) |]
val <- valD (varP selN) val <- valD (varP selN)
(normalB [| definePi $(foldl' (normalB [| definePi $(foldl'
(\e t -> [| $e + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |]) (\e t -> [| $e + runPersistableRecordWidth (persistableWidth :: PersistableRecordWidth $t) |])