haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Update ERaw to change the direction of NeedParens (parent now tells child context). Removed need for composite key constructor

Browse Source
This commit is contained in:
belevy 2021-01-17 14:47:32 -06:00
parent 1ba08abfb3
commit 89bd673c62
5 changed files with 236 additions and 247 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Database/Esqueleto/Experimental/ToAliasReference.hs
View File

@ -1,12 +1,13 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Database.Esqueleto.Experimental.ToAliasReference module Database.Esqueleto.Experimental.ToAliasReference
where where
import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.Internal hiding (From,
import Database.Esqueleto.Internal.PersistentImport from, on)
import Database.Esqueleto.Internal.PersistentImport
{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} {-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-}
type ToAliasReferenceT a = a type ToAliasReferenceT a = a
@ -18,7 +19,6 @@ class ToAliasReference a where
instance ToAliasReference (SqlExpr (Value a)) where instance ToAliasReference (SqlExpr (Value a)) where
toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent) toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent)
toAliasReference _ v@(ERaw _ _) = toAlias v toAliasReference _ v@(ERaw _ _) = toAlias v
toAliasReference _ v@(ECompositeKey _) = toAlias v
toAliasReference s (EValueReference _ b) = pure $ EValueReference s b toAliasReference s (EValueReference _ b) = pure $ EValueReference s b
instance ToAliasReference (SqlExpr (Entity a)) where instance ToAliasReference (SqlExpr (Entity a)) where

274
src/Database/Esqueleto/Internal/Internal.hs
View File

@ -249,7 +249,7 @@ orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }
-- | Ascending order of this field or SqlExpression. -- | Ascending order of this field or SqlExpression.
asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy
asc = EOrderBy ASC asc = EOrderBy ASC
-- | Descending order of this field or SqlExpression. -- | Descending order of this field or SqlExpression.
desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy
@ -540,15 +540,17 @@ subSelectUnsafe = sub SELECT
e ^. field e ^. field
| isIdField field = idFieldValue | isIdField field = idFieldValue
| otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, []) | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, [])
where where
idFieldValue = idFieldValue =
case entityKeyFields ed of case entityKeyFields ed of
idField:[] -> idField:[] ->
ERaw Never $ \info -> (dot info idField, []) ERaw noMeta $ \_ info -> (dot info idField, [])
idFields -> idFields ->
ECompositeKey $ \info -> dot info <$> idFields let renderedFields info = dot info <$> idFields
in ERaw noMeta{ sqlExprMetaCompositeFields = Just renderedFields} $
\p info -> (parensM p $ uncommas $ dot info <$> idFields, [])
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))
@ -598,7 +600,7 @@ EMaybe r ?. field = just (r ^. field)
-- | Lift a constant value from Haskell-land to the query. -- | Lift a constant value from Haskell-land to the query.
val :: PersistField typ => typ -> SqlExpr (Value typ) val :: PersistField typ => typ -> SqlExpr (Value typ)
val v = ERaw Never $ const ("?", [toPersistValue v]) val v = ERaw noMeta $ \_ _ -> ("?", [toPersistValue v])
-- | @IS NULL@ comparison. -- | @IS NULL@ comparison.
-- --
@ -624,27 +626,28 @@ val v = ERaw Never $ const ("?", [toPersistValue v])
isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool) isNothing :: PersistField typ => SqlExpr (Value (Maybe typ)) -> SqlExpr (Value Bool)
isNothing v = isNothing v =
case v of case v of
ERaw p f -> ERaw m f ->
isNullExpr $ first (parensM p) . f case sqlExprMetaCompositeFields m of
Just fields ->
ERaw noMeta $ \p info ->
first (parensM p) . flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) $ fields info
Nothing ->
ERaw noMeta $ \p info ->
first (parensM p) . isNullExpr $ f Never info
EAliasedValue i _ -> EAliasedValue i _ ->
isNullExpr $ aliasedValueIdentToRawSql i ERaw noMeta $ \p info ->
first (parensM p) . isNullExpr $ aliasedValueIdentToRawSql i info
EValueReference i i' -> EValueReference i i' ->
isNullExpr $ valueReferenceToRawSql i i' ERaw noMeta $ \p info ->
ECompositeKey f -> first (parensM p) . isNullExpr $ valueReferenceToRawSql i i' info
ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f
where where
isNullExpr :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value Bool) isNullExpr = first ((<> " IS NULL"))
isNullExpr g = ERaw Parens $ first ((<> " IS NULL")) . g
-- | Analogous to 'Just', promotes a value of type @typ@ into -- | Analogous to 'Just', promotes a value of type @typ@ into
-- one of type @Maybe typ@. It should hold that @'val' . Just -- one of type @Maybe typ@. It should hold that @'val' . Just
-- === just . 'val'@. -- === just . 'val'@.
just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ))
just exprVal = case exprVal of just = veryUnsafeCoerceSqlExprValue
ERaw p f -> ERaw p f
ECompositeKey f -> ECompositeKey f
EAliasedValue i v -> EAliasedValue i (just v)
EValueReference i i' -> EValueReference i i'
-- | @NULL@ value. -- | @NULL@ value.
nothing :: SqlExpr (Value (Maybe typ)) nothing :: SqlExpr (Value (Maybe typ))
@ -653,23 +656,22 @@ nothing = unsafeSqlValue "NULL"
-- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- | Join nested 'Maybe's in a 'Value' into one. This is useful when
-- calling aggregate functions on nullable fields. -- calling aggregate functions on nullable fields.
joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ))
joinV exprMM = case exprMM of joinV = veryUnsafeCoerceSqlExprValue
ERaw p f -> ERaw p f
ECompositeKey f -> ECompositeKey f
EAliasedValue i v -> EAliasedValue i (joinV v)
EValueReference i i' -> EValueReference i i'
countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a)
countHelper open close v = countHelper open close v =
case v of case v of
ERaw _ f -> countRawSql f ERaw meta f ->
if hasCompositeKeyMeta meta then
countRows
else
countRawSql (f Never)
EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i
EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i' EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i'
ECompositeKey _ -> countRows
where where
countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
countRawSql x = ERaw Never $ first (\b -> "COUNT" <> open <> parens b <> close) . x countRawSql x = ERaw noMeta $ \_ -> first (\b -> "COUNT" <> open <> parens b <> close) . x
-- | @COUNT(*)@ value. -- | @COUNT(*)@ value.
countRows :: Num a => SqlExpr (Value a) countRows :: Num a => SqlExpr (Value a)
@ -686,15 +688,16 @@ countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
countDistinct = countHelper "(DISTINCT " ")" countDistinct = countHelper "(DISTINCT " ")"
not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool) not_ :: SqlExpr (Value Bool) -> SqlExpr (Value Bool)
not_ v = ERaw Never (\info -> first ("NOT " <>) $ x info) not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info
where where
x info = x p info =
case v of case v of
ERaw p f -> ERaw m f ->
let (b, vals) = f info if hasCompositeKeyMeta m then
in (parensM p b, vals) throw (CompositeKeyErr NotError)
ECompositeKey _ -> else
throw (CompositeKeyErr NotError) let (b, vals) = f Never info
in (parensM p b, vals)
EAliasedValue i _ -> EAliasedValue i _ ->
aliasedValueIdentToRawSql i info aliasedValueIdentToRawSql i info
EValueReference i i' -> EValueReference i i' ->
@ -900,8 +903,7 @@ subList_select = EList . sub_select
-- | Lift a list of constant value from Haskell-land to the query. -- | Lift a list of constant value from Haskell-land to the query.
valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ) valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ)
valList [] = EEmptyList valList [] = EEmptyList
valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals) valList vals = EList $ ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), map toPersistValue vals )
, map toPersistValue vals )
-- | Same as 'just' but for 'ValueList'. Most of the time you -- | Same as 'just' but for 'ValueList'. Most of the time you
-- won't need it, though, because you can use 'just' from -- won't need it, though, because you can use 'just' from
@ -949,11 +951,17 @@ v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCo
-- return person -- return person
-- @ -- @
exists :: SqlQuery () -> SqlExpr (Value Bool) exists :: SqlQuery () -> SqlExpr (Value Bool)
exists = unsafeSqlFunction "EXISTS " . existsHelper exists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q
(b, vals) = f Never info
in ( parensM p $ "EXISTS " <> b, vals)
-- | @NOT EXISTS@ operator. -- | @NOT EXISTS@ operator.
notExists :: SqlQuery () -> SqlExpr (Value Bool) notExists :: SqlQuery () -> SqlExpr (Value Bool)
notExists = unsafeSqlFunction "NOT EXISTS " . existsHelper notExists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q
(b, vals) = f Never info
in ( parensM p $ "NOT EXISTS " <> b, vals)
-- | @SET@ clause used on @UPDATE@s. Note that while it's not -- | @SET@ clause used on @UPDATE@s. Note that while it's not
-- a type error to use this function on a @SELECT@, it will -- a type error to use this function on a @SELECT@, it will
@ -980,8 +988,7 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr)
-- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments. -- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments.
(<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) (<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b)
(<#) _ (ERaw _ f) = EInsert Proxy f (<#) _ (ERaw _ f) = EInsert Proxy (f Never)
(<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError)
(<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i (<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i
(<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i' (<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i'
@ -997,10 +1004,9 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr)
where where
g = g =
case v of case v of
ERaw _ f' -> f' ERaw _ f' -> f' Never
EAliasedValue i _ -> aliasedValueIdentToRawSql i EAliasedValue i _ -> aliasedValueIdentToRawSql i
EValueReference i i' -> valueReferenceToRawSql i i' EValueReference i i' -> valueReferenceToRawSql i i'
ECompositeKey _ -> throw (CompositeKeyErr CombineInsertionError)
-- | @CASE@ statement. For example: -- | @CASE@ statement. For example:
-- --
@ -1295,8 +1301,7 @@ renderUpdates
renderUpdates conn = uncommas' . concatMap renderUpdate renderUpdates conn = uncommas' . concatMap renderUpdate
where where
mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])]
mk (ERaw _ f) = [f info] mk (ERaw _ f) = [f Never info]
mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME
mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info] mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info]
mk (EValueReference i i') = [valueReferenceToRawSql i i' info] mk (EValueReference i i') = [valueReferenceToRawSql i i' info]
@ -2013,6 +2018,18 @@ type IdentInfo = (SqlBackend, IdentState)
useIdent :: IdentInfo -> Ident -> TLB.Builder useIdent :: IdentInfo -> Ident -> TLB.Builder
useIdent info (I ident) = fromDBName info $ DBName ident useIdent info (I ident) = fromDBName info $ DBName ident
data SqlExprMeta = SqlExprMeta
{ sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder])
}
noMeta :: SqlExprMeta
noMeta = SqlExprMeta
{ sqlExprMetaCompositeFields = Nothing
}
hasCompositeKeyMeta :: SqlExprMeta -> Bool
hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields
-- | An expression on the SQL backend. -- | An expression on the SQL backend.
-- --
-- There are many comments describing the constructors of this -- There are many comments describing the constructors of this
@ -2033,7 +2050,7 @@ data SqlExpr a where
-- connection (mainly for escaping names) and returns both an -- connection (mainly for escaping names) and returns both an
-- string ('TLB.Builder') and a list of values to be -- string ('TLB.Builder') and a list of values to be
-- interpolated by the SQL backend. -- interpolated by the SQL backend.
ERaw :: NeedParens -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a)
-- A raw expression with an alias -- A raw expression with an alias
@ -2082,7 +2099,6 @@ data SqlExpr a where
-- used in the context of a composite key. That's because it's -- used in the context of a composite key. That's because it's
-- impossible, e.g., for 'val' to disambiguate between these -- impossible, e.g., for 'val' to disambiguate between these
-- uses. -- uses.
ECompositeKey :: (IdentInfo -> [TLB.Builder]) -> SqlExpr (Value a)
-- 'EList' and 'EEmptyList' are used by list operators. -- 'EList' and 'EEmptyList' are used by list operators.
EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) EList :: SqlExpr (Value a) -> SqlExpr (ValueList a)
@ -2134,10 +2150,10 @@ setAux
-> SqlExpr (Update val) -> SqlExpr (Update val)
setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent)
where where
name = ERaw Never $ \info -> (fieldName info field, mempty) name = ERaw noMeta $ \_ info -> (fieldName info field, mempty)
sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
sub mode query = ERaw Parens $ \info -> toRawSql mode info query sub mode query = ERaw noMeta $ \_ info -> first parens $ toRawSql mode info query
fromDBName :: IdentInfo -> DBName -> TLB.Builder fromDBName :: IdentInfo -> DBName -> TLB.Builder
fromDBName (conn, _) = TLB.fromText . connEscapeName conn fromDBName (conn, _) = TLB.fromText . connEscapeName conn
@ -2156,31 +2172,28 @@ ifNotEmptyList (EList _) _ x = x
-- --
-- Since: 2.1.1 -- Since: 2.1.1
unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a) unsafeSqlCase :: PersistField a => [(SqlExpr (Value Bool), SqlExpr (Value a))] -> SqlExpr (Value a) -> SqlExpr (Value a)
unsafeSqlCase when v = ERaw Never buildCase unsafeSqlCase when v = ERaw noMeta buildCase
where where
buildCase :: IdentInfo -> (TLB.Builder, [PersistValue]) buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
buildCase info = buildCase p info =
let (elseText, elseVals) = valueToSql v info let (elseText, elseVals) = valueToSql v Parens info
(whenText, whenVals) = mapWhen when info (whenText, whenVals) = mapWhen when Parens info
in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals) in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals)
mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue]) mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) mapWhen [] _ _ = throw (UnexpectedCaseErr UnsafeSqlCaseError)
mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' mapWhen when' p info = foldl (foldHelp p info) (mempty, mempty) when'
foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue])
foldHelp _ _ (ECompositeKey _, _) = throw (CompositeKeyErr FoldHelpError) foldHelp p info (b0, vals0) (v1, v2) =
foldHelp _ _ (_, ECompositeKey _) = throw (CompositeKeyErr FoldHelpError) let (b1, vals1) = valueToSql v1 p info
foldHelp info (b0, vals0) (v1, v2) = (b2, vals2) = valueToSql v2 p info
let (b1, vals1) = valueToSql v1 info
(b2, vals2) = valueToSql v2 info
in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 ) in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 )
valueToSql :: SqlExpr (Value a) -> IdentInfo -> (TLB.Builder, [PersistValue]) valueToSql :: SqlExpr (Value a) -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
valueToSql (ERaw p f) = (first (parensM p)) . f valueToSql (ERaw _ f) p = f p
valueToSql (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError) valueToSql (EAliasedValue i _) _ = aliasedValueIdentToRawSql i
valueToSql (EAliasedValue i _) = aliasedValueIdentToRawSql i valueToSql (EValueReference i i') _ = valueReferenceToRawSql i i'
valueToSql (EValueReference i i') = valueReferenceToRawSql i i'
-- | (Internal) Create a custom binary operator. You /should/ -- | (Internal) Create a custom binary operator. You /should/
-- /not/ use this function directly since its type is very -- /not/ use this function directly since its type is very
@ -2195,32 +2208,35 @@ unsafeSqlCase when v = ERaw Never buildCase
-- In the example above, we constraint the arguments to be of the -- In the example above, we constraint the arguments to be of the
-- same type and constraint the result to be a boolean value. -- same type and constraint the result to be a boolean value.
unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) unsafeSqlBinOp :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f unsafeSqlBinOp op (ERaw m1 f1) (ERaw m2 f2)
| not (hasCompositeKeyMeta m1 || hasCompositeKeyMeta m2) = ERaw noMeta f
where where
f info = f p info =
let (b1, vals1) = f1 info let (b1, vals1) = f1 Parens info
(b2, vals2) = f2 info (b2, vals2) = f2 Parens info
in in
( parensM p1 b1 <> op <> parensM p2 b2 ( parensM p (b1 <> op <> b2)
, vals1 <> vals2 , vals1 <> vals2
) )
unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b) unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b)
where where
construct :: SqlExpr (Value a) -> SqlExpr (Value a) construct :: SqlExpr (Value a) -> SqlExpr (Value a)
construct (ERaw p f) = construct (ERaw m f) =
ERaw (if p == Never then Parens else Never) $ \info -> case sqlExprMetaCompositeFields m of
let (b1, vals) = f info Just fields ->
build ("?", [PersistList vals']) = ERaw noMeta $ \_ info -> (parens $ uncommas $ fields info, mempty)
(uncommas $ replicate (length vals') "?", vals') Nothing ->
build expr = expr ERaw noMeta $ \p info ->
in let (b1, vals) = f (if p == Never then Parens else Never) info
build (parensM p b1, vals) build ("?", [PersistList vals']) =
construct (ECompositeKey f) = (uncommas $ replicate (length vals') "?", vals')
ERaw Parens $ \info -> (uncommas $ f info, mempty) build expr = expr
in
first (parensM p) $ build (b1, vals)
construct (EAliasedValue i _) = construct (EAliasedValue i _) =
ERaw Never $ aliasedValueIdentToRawSql i ERaw noMeta $ const $ aliasedValueIdentToRawSql i
construct (EValueReference i i') = construct (EValueReference i i') =
ERaw Never $ valueReferenceToRawSql i i' ERaw noMeta $ const $ valueReferenceToRawSql i i'
{-# INLINE unsafeSqlBinOp #-} {-# INLINE unsafeSqlBinOp #-}
-- | Similar to 'unsafeSqlBinOp', but may also be applied to -- | Similar to 'unsafeSqlBinOp', but may also be applied to
@ -2248,18 +2264,19 @@ unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b)
-- no placeholders and split it on the commas. -- no placeholders and split it on the commas.
unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c)
unsafeSqlBinOpComposite op sep a b unsafeSqlBinOpComposite op sep a b
| isCompositeKey a || isCompositeKey b = ERaw Parens $ compose (listify a) (listify b) | isCompositeKey a || isCompositeKey b = ERaw noMeta $ const $ compose (listify a) (listify b)
| otherwise = unsafeSqlBinOp op a b | otherwise = unsafeSqlBinOp op a b
where where
isCompositeKey :: SqlExpr (Value x) -> Bool isCompositeKey :: SqlExpr (Value x) -> Bool
isCompositeKey (ECompositeKey _) = True isCompositeKey (ERaw m _) = hasCompositeKeyMeta m
isCompositeKey _ = False isCompositeKey _ = False
listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue]) listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue])
listify (ECompositeKey f) = flip (,) [] . f listify v
listify (ERaw _ f) = deconstruct . f | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = flip (,) [] . f
listify (EAliasedValue i _) = deconstruct . (aliasedValueIdentToRawSql i) | ERaw _ f <- v = deconstruct . f Parens
listify (EValueReference i i') = deconstruct . (valueReferenceToRawSql i i') | EAliasedValue i _ <- v = deconstruct . (aliasedValueIdentToRawSql i)
| EValueReference i i' <- v = deconstruct . (valueReferenceToRawSql i i')
deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])
deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals) deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals)
@ -2276,19 +2293,19 @@ unsafeSqlBinOpComposite op sep a b
bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2] bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2]
vc = v1 <> v2 vc = v1 <> v2
-- | (Internal) A raw SQL value. The same warning from -- | (Internal) A raw SQL value. The same warning from
-- 'unsafeSqlBinOp' applies to this function as well. -- 'unsafeSqlBinOp' applies to this function as well.
unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a)
unsafeSqlValue v = ERaw Never $ const (v, mempty) unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty)
{-# INLINE unsafeSqlValue #-} {-# INLINE unsafeSqlValue #-}
valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])
valueToFunctionArg info v = valueToFunctionArg info v =
case v of case v of
ERaw _ f -> f info ERaw _ f -> f Never info
EAliasedValue i _ -> aliasedValueIdentToRawSql i info EAliasedValue i _ -> aliasedValueIdentToRawSql i info
EValueReference i i' -> valueReferenceToRawSql i i' info EValueReference i i' -> valueReferenceToRawSql i i' info
ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError)
-- | (Internal) A raw SQL function. Once again, the same warning -- | (Internal) A raw SQL function. Once again, the same warning
-- from 'unsafeSqlBinOp' applies to this function as well. -- from 'unsafeSqlBinOp' applies to this function as well.
@ -2296,7 +2313,7 @@ unsafeSqlFunction
:: UnsafeSqlFunctionArgument a :: UnsafeSqlFunctionArgument a
=> TLB.Builder -> a -> SqlExpr (Value b) => TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunction name arg = unsafeSqlFunction name arg =
ERaw Never $ \info -> ERaw noMeta $ \p info ->
let (argsTLB, argsVals) = let (argsTLB, argsVals) =
uncommas' $ map (valueToFunctionArg info) $ toArgList arg uncommas' $ map (valueToFunctionArg info) $ toArgList arg
in in
@ -2310,7 +2327,7 @@ unsafeSqlExtractSubField
:: UnsafeSqlFunctionArgument a :: UnsafeSqlFunctionArgument a
=> TLB.Builder -> a -> SqlExpr (Value b) => TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlExtractSubField subField arg = unsafeSqlExtractSubField subField arg =
ERaw Never $ \info -> ERaw noMeta $ \_ info ->
let (argsTLB, argsVals) = let (argsTLB, argsVals) =
uncommas' $ map (valueToFunctionArg info) $ toArgList arg uncommas' $ map (valueToFunctionArg info) $ toArgList arg
in in
@ -2322,13 +2339,12 @@ unsafeSqlFunctionParens
:: UnsafeSqlFunctionArgument a :: UnsafeSqlFunctionArgument a
=> TLB.Builder -> a -> SqlExpr (Value b) => TLB.Builder -> a -> SqlExpr (Value b)
unsafeSqlFunctionParens name arg = unsafeSqlFunctionParens name arg =
ERaw Never $ \info -> ERaw noMeta $ \p info ->
let valueToFunctionArgParens v = let valueToFunctionArgParens v =
case v of case v of
ERaw p f -> first (parensM p) (f info) ERaw _ f -> f p info
EAliasedValue i _ -> aliasedValueIdentToRawSql i info EAliasedValue i _ -> aliasedValueIdentToRawSql i info
EValueReference i i' -> valueReferenceToRawSql i i' info EValueReference i i' -> valueReferenceToRawSql i i' info
ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError)
(argsTLB, argsVals) = (argsTLB, argsVals) =
uncommas' $ map valueToFunctionArgParens $ toArgList arg uncommas' $ map valueToFunctionArgParens $ toArgList arg
in in
@ -2337,16 +2353,13 @@ unsafeSqlFunctionParens name arg =
-- | (Internal) An explicit SQL type cast using CAST(value as type). -- | (Internal) An explicit SQL type cast using CAST(value as type).
-- See 'unsafeSqlBinOp' for warnings. -- See 'unsafeSqlBinOp' for warnings.
unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b) unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b)
unsafeSqlCastAs t v = ERaw Never ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . valueToText) unsafeSqlCastAs t v = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . valueToText)
where where
valueToText info = valueToText info =
case v of case v of
(ERaw p f) -> ERaw _ f -> f Never info
let (b, vals) = f info
in (parensM p b, vals)
EAliasedValue i _ -> aliasedValueIdentToRawSql i info EAliasedValue i _ -> aliasedValueIdentToRawSql i info
EValueReference i i' -> valueReferenceToRawSql i i' info EValueReference i i' -> valueReferenceToRawSql i i' info
ECompositeKey _ -> throw (CompositeKeyErr SqlCastAsError)
-- | (Internal) This class allows 'unsafeSqlFunction' to work with different -- | (Internal) This class allows 'unsafeSqlFunction' to work with different
-- numbers of arguments; specifically it allows providing arguments to a sql -- numbers of arguments; specifically it allows providing arguments to a sql
@ -2477,8 +2490,7 @@ instance ( UnsafeSqlFunctionArgument a
-- 'SqlExpr (Value b)'. You should /not/ use this function -- 'SqlExpr (Value b)'. You should /not/ use this function
-- unless you know what you're doing! -- unless you know what you're doing!
veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b)
veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f veryUnsafeCoerceSqlExprValue (ERaw m f) = ERaw m f
veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f
veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v) veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v)
veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i' veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i'
@ -2915,16 +2927,14 @@ makeFrom info mode fs = ret
fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "
fromKind FullOuterJoinKind = " FULL OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN "
makeOnClause (ERaw _ f) = first (" ON " <>) (f info) makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info)
makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError)
makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError) makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError)
makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError) makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError)
mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
mkExc (ERaw _ f) = mkExc (ERaw _ f) =
OnClauseWithoutMatchingJoinException $ OnClauseWithoutMatchingJoinException $
TL.unpack $ TLB.toLazyText $ fst (f info) TL.unpack $ TLB.toLazyText $ fst (f Never info)
mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError)
mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError) mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError)
mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError) mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError)
@ -2932,8 +2942,7 @@ makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])
makeSet _ [] = mempty makeSet _ [] = mempty
makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os
where where
mk (SetClause (ERaw _ f)) = [f info] mk (SetClause (ERaw _ f)) = [f Never info]
mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME
mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info] mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info]
mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info] mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info]
@ -2943,10 +2952,9 @@ makeWhere info (Where v) = first ("\nWHERE " <>) $ x info
where where
x = x =
case v of case v of
ERaw _ f -> f ERaw _ f -> f Never
EAliasedValue i _ -> aliasedValueIdentToRawSql i EAliasedValue i _ -> aliasedValueIdentToRawSql i
EValueReference i i' -> valueReferenceToRawSql i i' EValueReference i i' -> valueReferenceToRawSql i i'
ECompositeKey _ -> throw (CompositeKeyErr MakeWhereError)
makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])
makeGroupBy _ (GroupBy []) = (mempty, []) makeGroupBy _ (GroupBy []) = (mempty, [])
@ -2956,8 +2964,7 @@ makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
build = uncommas' $ map match fields build = uncommas' $ map match fields
match :: SomeValue -> (TLB.Builder, [PersistValue]) match :: SomeValue -> (TLB.Builder, [PersistValue])
match (SomeValue (ERaw _ f)) = f info match (SomeValue (ERaw _ f)) = f Never info
match (SomeValue (ECompositeKey f)) = (mconcat $ f info, mempty)
match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info
match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info
@ -2967,10 +2974,9 @@ makeHaving info (Where v) = first ("\nHAVING " <>) $ x info
where where
x = x =
case v of case v of
ERaw _ f -> f ERaw _ f -> f Never
EAliasedValue i _ -> aliasedValueIdentToRawSql i EAliasedValue i _ -> aliasedValueIdentToRawSql i
EValueReference i i' -> valueReferenceToRawSql i i' EValueReference i i' -> valueReferenceToRawSql i i'
ECompositeKey _ -> throw (CompositeKeyErr MakeHavingError)
-- makeHaving, makeWhere and makeOrderBy -- makeHaving, makeWhere and makeOrderBy
makeOrderByNoNewline makeOrderByNoNewline
@ -2979,17 +2985,17 @@ makeOrderByNoNewline _ [] = mempty
makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os
where where
mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] mk :: OrderByClause -> [(TLB.Builder, [PersistValue])]
mk (EOrderBy t (ECompositeKey f)) = mk (EOrderBy t v)
let fs = f info | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m =
vals = repeat [] let fs = f info
in zip (map (<> orderByType t) fs) vals vals = repeat []
mk (EOrderBy t v) = in zip (map (<> orderByType t) fs) vals
| otherwise =
let x = let x =
case v of case v of
ERaw p f -> (first (parensM p)) . f ERaw _ f -> f Never
EAliasedValue i _ -> aliasedValueIdentToRawSql i EAliasedValue i _ -> aliasedValueIdentToRawSql i
EValueReference i i' -> valueReferenceToRawSql i i' EValueReference i i' -> valueReferenceToRawSql i i'
ECompositeKey _ -> undefined -- defined above
in [ first (<> orderByType t) $ x info ] in [ first (<> orderByType t) $ x info ]
mk EOrderRandom = [first (<> "RANDOM()") mempty] mk EOrderRandom = [first (<> "RANDOM()") mempty]
@ -3151,12 +3157,11 @@ instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where
-- | Materialize a @SqlExpr (Value a)@. -- | Materialize a @SqlExpr (Value a)@.
materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])
materializeExpr info (ERaw p f) = materializeExpr info v
let (b, vals) = f info | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m =
in (parensM p b, vals) let bs = f info
materializeExpr info (ECompositeKey f) = in (uncommas $ map (parensM Parens) bs, [])
let bs = f info | ERaw _ f <- v = f Parens info
in (uncommas $ map (parensM Parens) bs, [])
materializeExpr info (EAliasedValue ident x) = materializeExpr info (EAliasedValue ident x) =
let (b, vals) = materializeExpr info x let (b, vals) = materializeExpr info x
in (b <> " AS " <> (useIdent info ident), vals) in (b <> " AS " <> (useIdent info ident), vals)
@ -3684,16 +3689,9 @@ insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal
-- @since 3.2.0 -- @since 3.2.0
renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text
renderExpr sqlBackend e = case e of renderExpr sqlBackend e = case e of
ERaw _ mkBuilderValues -> do ERaw _ mkBuilderValues ->
let (builder, _) = mkBuilderValues (sqlBackend, initialIdentState) let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState)
in (builderToText builder) in (builderToText builder)
ECompositeKey mkInfo ->
throw
. RenderExprUnexpectedECompositeKey
. builderToText
. mconcat
. mkInfo
$ (sqlBackend, initialIdentState)
EAliasedValue i _ -> EAliasedValue i _ ->
builderToText $ useIdent (sqlBackend, initialIdentState) i builderToText $ useIdent (sqlBackend, initialIdentState) i
EValueReference i i' -> EValueReference i i' ->

31
src/Database/Esqueleto/Internal/Sql.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
-- | This is an internal module, anything exported by this module -- | This is an internal module, anything exported by this module
@ -37,7 +37,6 @@ module Database.Esqueleto.Internal.Sql
-- * The guts -- * The guts
, unsafeSqlCase , unsafeSqlCase
, unsafeSqlBinOp , unsafeSqlBinOp
, unsafeSqlBinOpComposite
, unsafeSqlValue , unsafeSqlValue
, unsafeSqlCastAs , unsafeSqlCastAs
, unsafeSqlFunction , unsafeSqlFunction
@ -75,4 +74,4 @@ module Database.Esqueleto.Internal.Sql
, associateJoin , associateJoin
) where ) where
import Database.Esqueleto.Internal.Internal import Database.Esqueleto.Internal.Internal

57
src/Database/Esqueleto/PostgreSQL.hs
View File

@ -1,8 +1,8 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-- | This module contain PostgreSQL-specific functions. -- | This module contain PostgreSQL-specific functions.
@ -31,22 +31,23 @@ module Database.Esqueleto.PostgreSQL
) where ) where
#if __GLASGOW_HASKELL__ < 804 #if __GLASGOW_HASKELL__ < 804
import Data.Semigroup import Data.Semigroup
#endif #endif
import Control.Arrow (first, (***)) import Control.Arrow (first, (***))
import Control.Exception (throw) import Control.Exception (throw)
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO (..))
import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.Reader as R
import Data.Int (Int64) import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy (Proxy(..)) import Data.Proxy (Proxy (..))
import qualified Data.Text.Internal.Builder as TLB import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Internal hiding (random_) import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Esqueleto.Internal.PersistentImport hiding (upsert,
import Database.Persist.Class (OnlyOneUniqueKey) upsertBy)
import Database.Persist.Class (OnlyOneUniqueKey)
-- | (@random()@) Split out into database specific modules -- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.
@ -83,18 +84,18 @@ unsafeSqlAggregateFunction
-> a -> a
-> [OrderByClause] -> [OrderByClause]
-> SqlExpr (Value b) -> SqlExpr (Value b)
unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info -> unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
-- Don't add a space if we don't have order by clauses -- Don't add a space if we don't have order by clauses
orderTLBSpace = orderTLBSpace =
case orderByClauses of case orderByClauses of
[] -> "" [] -> ""
(_:_) -> " " (_:_) -> " "
(argsTLB, argsVals) = (argsTLB, argsVals) =
uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args uncommas' $ map (\(ERaw _ f) -> f Never info) $ toArgList args
aggMode = aggMode =
case mode of case mode of
AggModeAll -> "" AggModeAll -> ""
-- ALL is the default, so we don't need to -- ALL is the default, so we don't need to
-- specify it -- specify it
AggModeDistinct -> "DISTINCT " AggModeDistinct -> "DISTINCT "
@ -355,13 +356,11 @@ filterWhere
-> SqlExpr (Value Bool) -> SqlExpr (Value Bool)
-- ^ Filter clause -- ^ Filter clause
-> SqlExpr (Value a) -> SqlExpr (Value a)
filterWhere aggExpr clauseExpr = ERaw Never $ \info -> filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->
let (aggBuilder, aggValues) = case aggExpr of let (aggBuilder, aggValues) = case aggExpr of
ERaw _ aggF -> aggF info ERaw _ aggF -> aggF Never info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError
(clauseBuilder, clauseValues) = case clauseExpr of (clauseBuilder, clauseValues) = case clauseExpr of
ERaw _ clauseF -> clauseF info ERaw _ clauseF -> clauseF Never info
ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError
in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")" in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
, aggValues <> clauseValues , aggValues <> clauseValues
) )

111
test/Common/Test.hs
View File

@ -1,25 +1,25 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}
@ -62,37 +62,41 @@ module Common.Test
, Key(..) , Key(..)
) where ) where
import Control.Monad (forM_, replicateM, replicateM_, void) import Control.Monad (forM_, replicateM,
import Control.Monad.Catch (MonadCatch) replicateM_, void)
import Control.Monad.Reader (ask) import Control.Monad.Catch (MonadCatch)
import Data.Either import Control.Monad.Reader (ask)
import Data.Time import Data.Either
import Data.Time
#if __GLASGOW_HASKELL__ >= 806 #if __GLASGOW_HASKELL__ >= 806
import Control.Monad.Fail (MonadFail) import Control.Monad.Fail (MonadFail)
#endif #endif
import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT) import Control.Monad.Logger (MonadLogger (..),
import Control.Monad.Trans.Reader (ReaderT) NoLoggingT,
import qualified Data.Attoparsec.Text as AP runNoLoggingT)
import Data.Char (toLower, toUpper) import Control.Monad.Trans.Reader (ReaderT)
import Data.Monoid ((<>)) import qualified Data.Attoparsec.Text as AP
import Database.Esqueleto import Data.Char (toLower, toUpper)
import Database.Esqueleto.Experimental hiding (from, on) import Data.Monoid ((<>))
import qualified Database.Esqueleto.Experimental as Experimental import Database.Esqueleto
import Database.Persist.TH import Database.Esqueleto.Experimental hiding (from, on)
import Test.Hspec import qualified Database.Esqueleto.Experimental as Experimental
import UnliftIO import Database.Persist.TH
import Test.Hspec
import UnliftIO
import Data.Conduit (ConduitT, runConduit, (.|)) import Data.Conduit (ConduitT, runConduit,
import qualified Data.Conduit.List as CL (.|))
import qualified Data.List as L import qualified Data.Conduit.List as CL
import qualified Data.Set as S import qualified Data.List as L
import qualified Data.Text as Text import qualified Data.Set as S
import qualified Data.Text.Internal.Lazy as TL import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Internal.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Database.Esqueleto.Internal.ExprParser as P import qualified Database.Esqueleto.Internal.ExprParser as P
import qualified Database.Esqueleto.Internal.Sql as EI import qualified Database.Esqueleto.Internal.Sql as EI
import qualified UnliftIO.Resource as R import qualified UnliftIO.Resource as R
-- Test schema -- Test schema
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
@ -1078,17 +1082,6 @@ testSelectWhere run = describe "select where_" $ do
( val $ PointKey 1 2 ( val $ PointKey 1 2
, val $ PointKey 5 6 ) , val $ PointKey 5 6 )
liftIO $ ret `shouldBe` [()] liftIO $ ret `shouldBe` [()]
it "works when using ECompositeKey constructor" $ run $ do
insert_ $ Point 1 2 ""
ret <-
select $
from $ \p -> do
where_ $
p ^. PointId
`between`
( EI.ECompositeKey $ const ["3", "4"]
, EI.ECompositeKey $ const ["5", "6"] )
liftIO $ ret `shouldBe` []
it "works with avg_" $ run $ do it "works with avg_" $ run $ do
_ <- insert' p1 _ <- insert' p1