135 lines
4.6 KiB
Haskell
135 lines
4.6 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Database.Esqueleto.Utils.TH
|
|
( SqlIn(..)
|
|
, sqlInTuple, sqlInTuples
|
|
, _unValue
|
|
, unValueN, unValueNIs
|
|
, sqlIJproj, sqlLOJproj, sqlFOJproj, sqlMIXproj, sqlMIXproj'
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect)
|
|
|
|
import Database.Persist (PersistField)
|
|
|
|
import Language.Haskell.TH
|
|
|
|
import Data.List (foldr1, foldl)
|
|
|
|
import Utils.TH
|
|
import Control.Lens.Iso (Iso', iso)
|
|
|
|
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
|
|
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
|
|
|
|
instance SqlEq a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
|
|
sqlIn x = foldr (\x' e -> e E.||. sqlEq (E.val $ E.unValue x') x) (E.val False)
|
|
|
|
class PersistField a => SqlEq a where
|
|
sqlEq :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Bool)
|
|
|
|
instance {-# OVERLAPPABLE #-} PersistField a => SqlEq a where
|
|
sqlEq = (E.==.)
|
|
|
|
instance PersistField a => SqlEq (Maybe a) where
|
|
sqlEq a b = (E.isNothing a E.&&. E.isNothing b) E.||. a E.==. b
|
|
|
|
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)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
|
|
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
|
|
|
instanceD (cxt $ map (\v -> [t|SqlEq $(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)|]
|
|
]
|
|
) []
|
|
]
|
|
]
|
|
|
|
|
|
_unValue :: Iso' (E.Value v) v
|
|
_unValue = iso E.unValue E.Value
|
|
|
|
-- | 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.
|
|
--
|
|
-- > $(sqlIJproj 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
|
|
|
|
sqlFOJproj :: Int -> Int -> ExpQ
|
|
sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin
|
|
|
|
-- | Generic projections for Join-tuple
|
|
-- gives i-th element of n-tuple of left-associative join pairs, i.e.
|
|
--
|
|
-- > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3
|
|
sqlMIXproj :: String -> Int -> ExpQ
|
|
sqlMIXproj = leftAssociativeProjection . map decodeJoin
|
|
where
|
|
decodeJoin 'I' = 'E.InnerJoin
|
|
decodeJoin 'L' = 'E.LeftOuterJoin
|
|
decodeJoin 'R' = 'E.RightOuterJoin
|
|
decodeJoin 'F' = 'E.FullOuterJoin
|
|
decodeJoin 'O' = 'E.FullOuterJoin
|
|
decodeJoin 'X' = 'E.CrossJoin
|
|
decodeJoin 'C' = 'E.CrossJoin
|
|
decodeJoin c = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\"" -- always raised at compile time, so this is ok
|
|
|
|
-- Alternative using `refiy`, but impractical due to TH staging restrictions
|
|
-- and currently confuses type and expression constructors somehow
|
|
sqlMIXproj' :: Name -> Int -> ExpQ
|
|
sqlMIXproj' t i = do
|
|
ns <- extractConstructorNames t
|
|
-- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors
|
|
leftAssociativeProjection ns i
|