87 lines
2.7 KiB
Haskell
87 lines
2.7 KiB
Haskell
module Database.Esqueleto.Utils.TH
|
|
( SqlIn(..)
|
|
, sqlInTuple, sqlInTuples
|
|
, unValueN, unValueNIs
|
|
, sqlIJproj, sqlLOJproj
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
|
|
|
|
import Database.Persist (PersistField)
|
|
|
|
import Language.Haskell.TH
|
|
|
|
import Data.List (foldr1, foldl)
|
|
|
|
import Utils.TH
|
|
|
|
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
|
|
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
|
|
|
|
instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
|
|
x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
|
|
|
|
sqlInTuples :: [Int] -> DecsQ
|
|
sqlInTuples = mapM sqlInTuple
|
|
|
|
sqlInTuple :: Int -> DecQ
|
|
sqlInTuple arity = do
|
|
tyVars <- replicateM arity $ newName "t"
|
|
vVs <- replicateM arity $ newName "v"
|
|
xVs <- replicateM arity $ newName "x"
|
|
xsV <- newName "xs"
|
|
|
|
let
|
|
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
|
|
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
|
|
|
instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
|
[ funD 'sqlIn
|
|
[ clause [tupP $ map varP xVs, varP xsV]
|
|
( guardedB
|
|
[ normalGE [e|null $(varE xsV)|] [e|E.val False|]
|
|
, normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
|
|
]
|
|
) []
|
|
]
|
|
]
|
|
|
|
-- | Generic unValuing of Tuples of Values, i.e.
|
|
--
|
|
-- > $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
|
|
unValueN :: Int -> ExpQ
|
|
unValueN arity = do
|
|
vs <- replicateM arity $ newName "v"
|
|
let pat = tupP $ map varP vs
|
|
let uvE v = [e|E.unValue $(varE v)|]
|
|
let rhs = tupE $ map uvE vs
|
|
lam1E pat rhs
|
|
|
|
-- | Generic unValuing of certain indices of a Tuple, i.e.
|
|
--
|
|
-- > $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
|
|
unValueNIs :: Int -> [Int] -> ExpQ
|
|
unValueNIs arity uvIdx = do
|
|
vs <- replicateM arity $ newName "v"
|
|
let pat = tupP $ map varP vs
|
|
let rhs = tupE $ zipWith (curry uvEi) vs [1 ..]
|
|
lam1E pat rhs
|
|
where
|
|
uvEi (v,i) | i `elem` uvIdx = [e|E.unValue $(varE v)|]
|
|
| otherwise = varE v
|
|
|
|
|
|
|
|
-- | Generic projections for InnerJoin-tuples
|
|
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e.
|
|
--
|
|
-- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
|
|
sqlIJproj :: Int -> Int -> ExpQ
|
|
sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
|
|
|
|
sqlLOJproj :: Int -> Int -> ExpQ
|
|
sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
|