From 89bd673c62a4ecf2a905ff97da8d226164093629 Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 17 Jan 2021 14:47:32 -0600 Subject: [PATCH 01/11] Update ERaw to change the direction of NeedParens (parent now tells child context). Removed need for composite key constructor --- .../Experimental/ToAliasReference.hs | 10 +- src/Database/Esqueleto/Internal/Internal.hs | 274 +++++++++--------- src/Database/Esqueleto/Internal/Sql.hs | 31 +- src/Database/Esqueleto/PostgreSQL.hs | 57 ++-- test/Common/Test.hs | 111 ++++--- 5 files changed, 236 insertions(+), 247 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index b01bbe6..a3ed1f8 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -1,12 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAliasReference where -import Database.Esqueleto.Experimental.ToAlias -import Database.Esqueleto.Internal.Internal hiding (From, from, on) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Internal.Internal hiding (From, + 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." #-} type ToAliasReferenceT a = a @@ -18,7 +19,6 @@ class ToAliasReference a where instance ToAliasReference (SqlExpr (Value a)) where toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent) toAliasReference _ v@(ERaw _ _) = toAlias v - toAliasReference _ v@(ECompositeKey _) = toAlias v toAliasReference s (EValueReference _ b) = pure $ EValueReference s b instance ToAliasReference (SqlExpr (Entity a)) where diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index c5e0937..d9b9182 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -249,7 +249,7 @@ orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } -- | Ascending order of this field or SqlExpression. asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy -asc = EOrderBy ASC +asc = EOrderBy ASC -- | Descending order of this field or SqlExpression. desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy @@ -540,15 +540,17 @@ subSelectUnsafe = sub SELECT e ^. field | isIdField field = idFieldValue - | otherwise = ERaw Never $ \info -> (dot info $ persistFieldDef field, []) + | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) where idFieldValue = case entityKeyFields ed of idField:[] -> - ERaw Never $ \info -> (dot info idField, []) + ERaw noMeta $ \_ info -> (dot info idField, []) 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))) @@ -598,7 +600,7 @@ EMaybe r ?. field = just (r ^. field) -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> SqlExpr (Value typ) -val v = ERaw Never $ const ("?", [toPersistValue v]) +val v = ERaw noMeta $ \_ _ -> ("?", [toPersistValue v]) -- | @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 v = case v of - ERaw p f -> - isNullExpr $ first (parensM p) . f + ERaw m 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 _ -> - isNullExpr $ aliasedValueIdentToRawSql i + ERaw noMeta $ \p info -> + first (parensM p) . isNullExpr $ aliasedValueIdentToRawSql i info EValueReference i i' -> - isNullExpr $ valueReferenceToRawSql i i' - ECompositeKey f -> - ERaw Parens $ flip (,) [] . (intersperseB " AND " . map (<> " IS NULL")) . f + ERaw noMeta $ \p info -> + first (parensM p) . isNullExpr $ valueReferenceToRawSql i i' info where - isNullExpr :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value Bool) - isNullExpr g = ERaw Parens $ first ((<> " IS NULL")) . g + isNullExpr = first ((<> " IS NULL")) -- | Analogous to 'Just', promotes a value of type @typ@ into -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) -just exprVal = case exprVal of - ERaw p f -> ERaw p f - ECompositeKey f -> ECompositeKey f - EAliasedValue i v -> EAliasedValue i (just v) - EValueReference i i' -> EValueReference i i' +just = veryUnsafeCoerceSqlExprValue -- | @NULL@ value. 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 -- calling aggregate functions on nullable fields. joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) -joinV exprMM = case exprMM of - ERaw p f -> ERaw p f - ECompositeKey f -> ECompositeKey f - EAliasedValue i v -> EAliasedValue i (joinV v) - EValueReference i i' -> EValueReference i i' +joinV = veryUnsafeCoerceSqlExprValue countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) countHelper open close v = case v of - ERaw _ f -> countRawSql f + ERaw meta f -> + if hasCompositeKeyMeta meta then + countRows + else + countRawSql (f Never) EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i' - ECompositeKey _ -> countRows where 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. countRows :: Num a => SqlExpr (Value a) @@ -686,15 +688,16 @@ countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) countDistinct = countHelper "(DISTINCT " ")" 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 - x info = + x p info = case v of - ERaw p f -> - let (b, vals) = f info - in (parensM p b, vals) - ECompositeKey _ -> - throw (CompositeKeyErr NotError) + ERaw m f -> + if hasCompositeKeyMeta m then + throw (CompositeKeyErr NotError) + else + let (b, vals) = f Never info + in (parensM p b, vals) EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> @@ -900,8 +903,7 @@ subList_select = EList . sub_select -- | Lift a list of constant value from Haskell-land to the query. valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ) valList [] = EEmptyList -valList vals = EList $ ERaw Parens $ const ( uncommas ("?" <$ vals) - , map toPersistValue vals ) +valList vals = EList $ ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), map toPersistValue vals ) -- | Same as 'just' but for 'ValueList'. Most of the time you -- 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 -- @ 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. 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 -- 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. (<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(<#) _ (ERaw _ f) = EInsert Proxy f -(<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError) +(<#) _ (ERaw _ f) = EInsert Proxy (f Never) (<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i (<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i' @@ -997,10 +1004,9 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) where g = case v of - ERaw _ f' -> f' + ERaw _ f' -> f' Never EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' - ECompositeKey _ -> throw (CompositeKeyErr CombineInsertionError) -- | @CASE@ statement. For example: -- @@ -1295,8 +1301,7 @@ renderUpdates renderUpdates conn = uncommas' . concatMap renderUpdate where mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] - mk (ERaw _ f) = [f info] - mk (ECompositeKey _) = throw (CompositeKeyErr MakeSetError) -- FIXME + mk (ERaw _ f) = [f Never info] mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info] mk (EValueReference i i') = [valueReferenceToRawSql i i' info] @@ -2013,6 +2018,18 @@ type IdentInfo = (SqlBackend, IdentState) useIdent :: IdentInfo -> Ident -> TLB.Builder 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. -- -- 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 -- string ('TLB.Builder') and a list of values to be -- 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 @@ -2082,7 +2099,6 @@ data SqlExpr a where -- used in the context of a composite key. That's because it's -- impossible, e.g., for 'val' to disambiguate between these -- uses. - ECompositeKey :: (IdentInfo -> [TLB.Builder]) -> SqlExpr (Value a) -- 'EList' and 'EEmptyList' are used by list operators. EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) @@ -2134,10 +2150,10 @@ setAux -> SqlExpr (Update val) setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) 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 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 (conn, _) = TLB.fromText . connEscapeName conn @@ -2156,31 +2172,28 @@ ifNotEmptyList (EList _) _ x = x -- -- Since: 2.1.1 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 - buildCase :: IdentInfo -> (TLB.Builder, [PersistValue]) - buildCase info = - let (elseText, elseVals) = valueToSql v info - (whenText, whenVals) = mapWhen when info + buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) + buildCase p info = + let (elseText, elseVals) = valueToSql v Parens info + (whenText, whenVals) = mapWhen when Parens info in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals) - mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue]) - mapWhen [] _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) - mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when' + mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) + mapWhen [] _ _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) + 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 _ _ (ECompositeKey _, _) = throw (CompositeKeyErr FoldHelpError) - foldHelp _ _ (_, ECompositeKey _) = throw (CompositeKeyErr FoldHelpError) - foldHelp info (b0, vals0) (v1, v2) = - let (b1, vals1) = valueToSql v1 info - (b2, vals2) = valueToSql v2 info + foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue]) + foldHelp p info (b0, vals0) (v1, v2) = + let (b1, vals1) = valueToSql v1 p info + (b2, vals2) = valueToSql v2 p info in ( b0 <> " WHEN " <> b1 <> " THEN " <> b2, vals0 <> vals1 <> vals2 ) - valueToSql :: SqlExpr (Value a) -> IdentInfo -> (TLB.Builder, [PersistValue]) - valueToSql (ERaw p f) = (first (parensM p)) . f - valueToSql (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError) - valueToSql (EAliasedValue i _) = aliasedValueIdentToRawSql i - valueToSql (EValueReference i i') = valueReferenceToRawSql i i' + valueToSql :: SqlExpr (Value a) -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) + valueToSql (ERaw _ f) p = f p + valueToSql (EAliasedValue i _) _ = aliasedValueIdentToRawSql i + valueToSql (EValueReference i i') _ = valueReferenceToRawSql i i' -- | (Internal) Create a custom binary operator. You /should/ -- /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 -- same type and constraint the result to be a boolean value. 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 - f info = - let (b1, vals1) = f1 info - (b2, vals2) = f2 info + f p info = + let (b1, vals1) = f1 Parens info + (b2, vals2) = f2 Parens info in - ( parensM p1 b1 <> op <> parensM p2 b2 + ( parensM p (b1 <> op <> b2) , vals1 <> vals2 ) unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b) where construct :: SqlExpr (Value a) -> SqlExpr (Value a) - construct (ERaw p f) = - ERaw (if p == Never then Parens else Never) $ \info -> - let (b1, vals) = f info - build ("?", [PersistList vals']) = - (uncommas $ replicate (length vals') "?", vals') - build expr = expr - in - build (parensM p b1, vals) - construct (ECompositeKey f) = - ERaw Parens $ \info -> (uncommas $ f info, mempty) + construct (ERaw m f) = + case sqlExprMetaCompositeFields m of + Just fields -> + ERaw noMeta $ \_ info -> (parens $ uncommas $ fields info, mempty) + Nothing -> + ERaw noMeta $ \p info -> + let (b1, vals) = f (if p == Never then Parens else Never) info + build ("?", [PersistList vals']) = + (uncommas $ replicate (length vals') "?", vals') + build expr = expr + in + first (parensM p) $ build (b1, vals) construct (EAliasedValue i _) = - ERaw Never $ aliasedValueIdentToRawSql i + ERaw noMeta $ const $ aliasedValueIdentToRawSql i construct (EValueReference i i') = - ERaw Never $ valueReferenceToRawSql i i' + ERaw noMeta $ const $ valueReferenceToRawSql i i' {-# INLINE unsafeSqlBinOp #-} -- | 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. unsafeSqlBinOpComposite :: TLB.Builder -> TLB.Builder -> SqlExpr (Value a) -> SqlExpr (Value b) -> SqlExpr (Value c) 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 where isCompositeKey :: SqlExpr (Value x) -> Bool - isCompositeKey (ECompositeKey _) = True + isCompositeKey (ERaw m _) = hasCompositeKeyMeta m isCompositeKey _ = False listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue]) - listify (ECompositeKey f) = flip (,) [] . f - listify (ERaw _ f) = deconstruct . f - listify (EAliasedValue i _) = deconstruct . (aliasedValueIdentToRawSql i) - listify (EValueReference i i') = deconstruct . (valueReferenceToRawSql i i') + listify v + | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = flip (,) [] . f + | ERaw _ f <- v = deconstruct . f Parens + | EAliasedValue i _ <- v = deconstruct . (aliasedValueIdentToRawSql i) + | EValueReference i i' <- v = deconstruct . (valueReferenceToRawSql i i') deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) 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] vc = v1 <> v2 + -- | (Internal) A raw SQL value. The same warning from -- 'unsafeSqlBinOp' applies to this function as well. unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) -unsafeSqlValue v = ERaw Never $ const (v, mempty) +unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty) {-# INLINE unsafeSqlValue #-} valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) valueToFunctionArg info v = case v of - ERaw _ f -> f info + ERaw _ f -> f Never info EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> valueReferenceToRawSql i i' info - ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError) -- | (Internal) A raw SQL function. Once again, the same warning -- from 'unsafeSqlBinOp' applies to this function as well. @@ -2296,7 +2313,7 @@ unsafeSqlFunction :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunction name arg = - ERaw Never $ \info -> + ERaw noMeta $ \p info -> let (argsTLB, argsVals) = uncommas' $ map (valueToFunctionArg info) $ toArgList arg in @@ -2310,7 +2327,7 @@ unsafeSqlExtractSubField :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlExtractSubField subField arg = - ERaw Never $ \info -> + ERaw noMeta $ \_ info -> let (argsTLB, argsVals) = uncommas' $ map (valueToFunctionArg info) $ toArgList arg in @@ -2322,13 +2339,12 @@ unsafeSqlFunctionParens :: UnsafeSqlFunctionArgument a => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunctionParens name arg = - ERaw Never $ \info -> + ERaw noMeta $ \p info -> let valueToFunctionArgParens v = case v of - ERaw p f -> first (parensM p) (f info) + ERaw _ f -> f p info EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> valueReferenceToRawSql i i' info - ECompositeKey _ -> throw (CompositeKeyErr SqlFunctionError) (argsTLB, argsVals) = uncommas' $ map valueToFunctionArgParens $ toArgList arg in @@ -2337,16 +2353,13 @@ unsafeSqlFunctionParens name arg = -- | (Internal) An explicit SQL type cast using CAST(value as type). -- See 'unsafeSqlBinOp' for warnings. 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 valueToText info = case v of - (ERaw p f) -> - let (b, vals) = f info - in (parensM p b, vals) + ERaw _ f -> f Never info EAliasedValue i _ -> aliasedValueIdentToRawSql i info EValueReference i i' -> valueReferenceToRawSql i i' info - ECompositeKey _ -> throw (CompositeKeyErr SqlCastAsError) -- | (Internal) This class allows 'unsafeSqlFunction' to work with different -- 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 -- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) -veryUnsafeCoerceSqlExprValue (ERaw p f) = ERaw p f -veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f +veryUnsafeCoerceSqlExprValue (ERaw m f) = ERaw m f veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v) veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i' @@ -2915,16 +2927,14 @@ makeFrom info mode fs = ret fromKind RightOuterJoinKind = " RIGHT OUTER JOIN " fromKind FullOuterJoinKind = " FULL OUTER JOIN " - makeOnClause (ERaw _ f) = first (" ON " <>) (f info) - makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError) + makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info) makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError) makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ - TL.unpack $ TLB.toLazyText $ fst (f info) - mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError) + TL.unpack $ TLB.toLazyText $ fst (f Never info) mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError) mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError) @@ -2932,8 +2942,7 @@ makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os where - mk (SetClause (ERaw _ f)) = [f info] - mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME + mk (SetClause (ERaw _ f)) = [f Never info] mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info] mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info] @@ -2943,10 +2952,9 @@ makeWhere info (Where v) = first ("\nWHERE " <>) $ x info where x = case v of - ERaw _ f -> f + ERaw _ f -> f Never EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' - ECompositeKey _ -> throw (CompositeKeyErr MakeWhereError) makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy _ (GroupBy []) = (mempty, []) @@ -2956,8 +2964,7 @@ makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build build = uncommas' $ map match fields match :: SomeValue -> (TLB.Builder, [PersistValue]) - match (SomeValue (ERaw _ f)) = f info - match (SomeValue (ECompositeKey f)) = (mconcat $ f info, mempty) + match (SomeValue (ERaw _ f)) = f Never info match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info @@ -2967,10 +2974,9 @@ makeHaving info (Where v) = first ("\nHAVING " <>) $ x info where x = case v of - ERaw _ f -> f + ERaw _ f -> f Never EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' - ECompositeKey _ -> throw (CompositeKeyErr MakeHavingError) -- makeHaving, makeWhere and makeOrderBy makeOrderByNoNewline @@ -2979,17 +2985,17 @@ makeOrderByNoNewline _ [] = mempty makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os where mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] - mk (EOrderBy t (ECompositeKey f)) = - let fs = f info - vals = repeat [] - in zip (map (<> orderByType t) fs) vals - mk (EOrderBy t v) = + mk (EOrderBy t v) + | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = + let fs = f info + vals = repeat [] + in zip (map (<> orderByType t) fs) vals + | otherwise = let x = case v of - ERaw p f -> (first (parensM p)) . f + ERaw _ f -> f Never EAliasedValue i _ -> aliasedValueIdentToRawSql i EValueReference i i' -> valueReferenceToRawSql i i' - ECompositeKey _ -> undefined -- defined above in [ first (<> orderByType t) $ x info ] mk EOrderRandom = [first (<> "RANDOM()") mempty] @@ -3151,12 +3157,11 @@ instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where -- | Materialize a @SqlExpr (Value a)@. materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) -materializeExpr info (ERaw p f) = - let (b, vals) = f info - in (parensM p b, vals) -materializeExpr info (ECompositeKey f) = - let bs = f info - in (uncommas $ map (parensM Parens) bs, []) +materializeExpr info v + | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = + let bs = f info + in (uncommas $ map (parensM Parens) bs, []) + | ERaw _ f <- v = f Parens info materializeExpr info (EAliasedValue ident x) = let (b, vals) = materializeExpr info x in (b <> " AS " <> (useIdent info ident), vals) @@ -3684,16 +3689,9 @@ insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal -- @since 3.2.0 renderExpr :: SqlBackend -> SqlExpr (Value Bool) -> T.Text renderExpr sqlBackend e = case e of - ERaw _ mkBuilderValues -> do - let (builder, _) = mkBuilderValues (sqlBackend, initialIdentState) + ERaw _ mkBuilderValues -> + let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState) in (builderToText builder) - ECompositeKey mkInfo -> - throw - . RenderExprUnexpectedECompositeKey - . builderToText - . mconcat - . mkInfo - $ (sqlBackend, initialIdentState) EAliasedValue i _ -> builderToText $ useIdent (sqlBackend, initialIdentState) i EValueReference i i' -> diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 3b92975..39e895b 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | This is an internal module, anything exported by this module @@ -37,7 +37,6 @@ module Database.Esqueleto.Internal.Sql -- * The guts , unsafeSqlCase , unsafeSqlBinOp - , unsafeSqlBinOpComposite , unsafeSqlValue , unsafeSqlCastAs , unsafeSqlFunction @@ -75,4 +74,4 @@ module Database.Esqueleto.Internal.Sql , associateJoin ) where -import Database.Esqueleto.Internal.Internal +import Database.Esqueleto.Internal.Internal diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index bf571f0..7262dce 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module contain PostgreSQL-specific functions. @@ -31,22 +31,23 @@ module Database.Esqueleto.PostgreSQL ) where #if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup +import Data.Semigroup #endif -import Control.Arrow (first, (***)) -import Control.Exception (throw) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO(..)) -import qualified Control.Monad.Trans.Reader as R -import Data.Int (Int64) -import Data.List.NonEmpty (NonEmpty((:|))) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Proxy (Proxy(..)) -import qualified Data.Text.Internal.Builder as TLB -import Data.Time.Clock (UTCTime) -import Database.Esqueleto.Internal.Internal hiding (random_) -import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) -import Database.Persist.Class (OnlyOneUniqueKey) +import Control.Arrow (first, (***)) +import Control.Exception (throw) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Control.Monad.Trans.Reader as R +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy (Proxy (..)) +import qualified Data.Text.Internal.Builder as TLB +import Data.Time.Clock (UTCTime) +import Database.Esqueleto.Internal.Internal hiding (random_) +import Database.Esqueleto.Internal.PersistentImport hiding (upsert, + upsertBy) +import Database.Persist.Class (OnlyOneUniqueKey) -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -83,18 +84,18 @@ unsafeSqlAggregateFunction -> a -> [OrderByClause] -> 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 -- Don't add a space if we don't have order by clauses orderTLBSpace = case orderByClauses of - [] -> "" + [] -> "" (_:_) -> " " (argsTLB, argsVals) = - uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args + uncommas' $ map (\(ERaw _ f) -> f Never info) $ toArgList args aggMode = case mode of - AggModeAll -> "" + AggModeAll -> "" -- ALL is the default, so we don't need to -- specify it AggModeDistinct -> "DISTINCT " @@ -355,13 +356,11 @@ filterWhere -> SqlExpr (Value Bool) -- ^ Filter clause -> SqlExpr (Value a) -filterWhere aggExpr clauseExpr = ERaw Never $ \info -> +filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info -> let (aggBuilder, aggValues) = case aggExpr of - ERaw _ aggF -> aggF info - ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError + ERaw _ aggF -> aggF Never info (clauseBuilder, clauseValues) = case clauseExpr of - ERaw _ clauseF -> clauseF info - ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError + ERaw _ clauseF -> clauseF Never info in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")" , aggValues <> clauseValues ) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 414908e..1dcb918 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -62,37 +62,41 @@ module Common.Test , Key(..) ) where -import Control.Monad (forM_, replicateM, replicateM_, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Reader (ask) -import Data.Either -import Data.Time +import Control.Monad (forM_, replicateM, + replicateM_, void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Reader (ask) +import Data.Either +import Data.Time #if __GLASGOW_HASKELL__ >= 806 -import Control.Monad.Fail (MonadFail) +import Control.Monad.Fail (MonadFail) #endif -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Data.Attoparsec.Text as AP -import Data.Char (toLower, toUpper) -import Data.Monoid ((<>)) -import Database.Esqueleto -import Database.Esqueleto.Experimental hiding (from, on) -import qualified Database.Esqueleto.Experimental as Experimental -import Database.Persist.TH -import Test.Hspec -import UnliftIO +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (MonadLogger (..), + NoLoggingT, + runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT) +import qualified Data.Attoparsec.Text as AP +import Data.Char (toLower, toUpper) +import Data.Monoid ((<>)) +import Database.Esqueleto +import Database.Esqueleto.Experimental hiding (from, on) +import qualified Database.Esqueleto.Experimental as Experimental +import Database.Persist.TH +import Test.Hspec +import UnliftIO -import Data.Conduit (ConduitT, runConduit, (.|)) -import qualified Data.Conduit.List as CL -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Text as Text -import qualified Data.Text.Internal.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB +import Data.Conduit (ConduitT, runConduit, + (.|)) +import qualified Data.Conduit.List as CL +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Text as Text +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.Sql as EI -import qualified UnliftIO.Resource as R +import qualified Database.Esqueleto.Internal.Sql as EI +import qualified UnliftIO.Resource as R -- Test schema share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| @@ -1078,17 +1082,6 @@ testSelectWhere run = describe "select where_" $ do ( val $ PointKey 1 2 , val $ PointKey 5 6 ) 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 _ <- insert' p1 From 8a9b586f296e175bfb5ee8a83411e84e33efc323 Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 17 Jan 2021 16:33:10 -0600 Subject: [PATCH 02/11] Get rid of AliasedValue and ValueReference; added sqlExprMetaAlias to SqlExprMeta --- .../Esqueleto/Experimental/ToAlias.hs | 15 ++-- .../Experimental/ToAliasReference.hs | 7 +- src/Database/Esqueleto/Internal/Internal.hs | 88 ++----------------- 3 files changed, 22 insertions(+), 88 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index 9621596..fdb9430 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -1,12 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAlias where -import Database.Esqueleto.Internal.Internal hiding (From, from, on) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Internal.Internal hiding (From, + from, on) +import Database.Esqueleto.Internal.PersistentImport {-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} type ToAliasT a = a @@ -16,10 +17,12 @@ class ToAlias a where toAlias :: a -> SqlQuery a instance ToAlias (SqlExpr (Value a)) where - toAlias v@(EAliasedValue _ _) = pure v - toAlias v = do + toAlias (ERaw m f) + | Nothing <- sqlExprMetaAlias m = do ident <- newIdentFor (DBName "v") - pure $ EAliasedValue ident v + pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> + let (b, v) = f Never info + in (b <> " AS " <> useIdent info ident, []) instance ToAlias (SqlExpr (Entity a)) where toAlias v@(EAliasedEntityReference _ _) = pure v diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index a3ed1f8..568758c 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAliasReference @@ -17,9 +18,9 @@ class ToAliasReference a where toAliasReference :: Ident -> a -> SqlQuery a instance ToAliasReference (SqlExpr (Value a)) where - toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent) - toAliasReference _ v@(ERaw _ _) = toAlias v - toAliasReference s (EValueReference _ b) = pure $ EValueReference s b + toAliasReference aliasSource (ERaw m _) + | Just alias <- sqlExprMetaAlias m = pure $ ERaw noMeta $ \p info -> + (useIdent info aliasSource <> "." <> useIdent info alias, []) instance ToAliasReference (SqlExpr (Entity a)) where toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index d9b9182..f57c5d0 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -527,7 +527,8 @@ subSelectUnsafe = sub SELECT -> EntityField val typ -> SqlExpr (Value typ) (EAliasedEntityReference source base) ^. field = - EValueReference source (\_ -> aliasedEntityColumnIdent base fieldDef) + ERaw noMeta $ \_ info -> + (useIdent info source <> "." <> useIdent info (aliasedEntityColumnIdent base fieldDef), []) where fieldDef = if isIdField field then @@ -634,12 +635,6 @@ isNothing v = Nothing -> ERaw noMeta $ \p info -> first (parensM p) . isNullExpr $ f Never info - EAliasedValue i _ -> - ERaw noMeta $ \p info -> - first (parensM p) . isNullExpr $ aliasedValueIdentToRawSql i info - EValueReference i i' -> - ERaw noMeta $ \p info -> - first (parensM p) . isNullExpr $ valueReferenceToRawSql i i' info where isNullExpr = first ((<> " IS NULL")) @@ -667,8 +662,6 @@ countHelper open close v = countRows else countRawSql (f Never) - EAliasedValue i _ -> countRawSql $ aliasedValueIdentToRawSql i - EValueReference i i' -> countRawSql $ valueReferenceToRawSql i i' where countRawSql :: (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) countRawSql x = ERaw noMeta $ \_ -> first (\b -> "COUNT" <> open <> parens b <> close) . x @@ -698,10 +691,6 @@ not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info else let (b, vals) = f Never info in (parensM p b, vals) - EAliasedValue i _ -> - aliasedValueIdentToRawSql i info - EValueReference i i' -> - valueReferenceToRawSql i i' info (==.) :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool) (==.) = unsafeSqlBinOpComposite " = " " AND " @@ -989,9 +978,6 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments. (<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) (<#) _ (ERaw _ f) = EInsert Proxy (f Never) -(<#) _ (EAliasedValue i _) = EInsert Proxy $ aliasedValueIdentToRawSql i -(<#) _ (EValueReference i i') = EInsert Proxy $ valueReferenceToRawSql i i' - -- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor (<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b) @@ -1005,8 +991,6 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) g = case v of ERaw _ f' -> f' Never - EAliasedValue i _ -> aliasedValueIdentToRawSql i - EValueReference i i' -> valueReferenceToRawSql i i' -- | @CASE@ statement. For example: -- @@ -1302,8 +1286,6 @@ renderUpdates conn = uncommas' . concatMap renderUpdate where mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] mk (ERaw _ f) = [f Never info] - mk (EAliasedValue i _) = [aliasedValueIdentToRawSql i info] - mk (EValueReference i i') = [valueReferenceToRawSql i i' info] renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused @@ -2020,11 +2002,13 @@ useIdent info (I ident) = fromDBName info $ DBName ident data SqlExprMeta = SqlExprMeta { sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) + , sqlExprMetaAlias :: Maybe Ident } noMeta :: SqlExprMeta noMeta = SqlExprMeta { sqlExprMetaCompositeFields = Nothing + , sqlExprMetaAlias = Nothing } hasCompositeKeyMeta :: SqlExprMeta -> Bool @@ -2052,13 +2036,6 @@ data SqlExpr a where -- interpolated by the SQL backend. ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) - - -- A raw expression with an alias - EAliasedValue :: Ident -> SqlExpr (Value a) -> SqlExpr (Value a) - - -- A reference to an aliased field in a table or subquery - EValueReference :: Ident -> (IdentInfo -> Ident) -> SqlExpr (Value a) - -- A composite key. -- -- Persistent uses the same 'PersistList' constructor for both @@ -2192,8 +2169,6 @@ unsafeSqlCase when v = ERaw noMeta buildCase valueToSql :: SqlExpr (Value a) -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) valueToSql (ERaw _ f) p = f p - valueToSql (EAliasedValue i _) _ = aliasedValueIdentToRawSql i - valueToSql (EValueReference i i') _ = valueReferenceToRawSql i i' -- | (Internal) Create a custom binary operator. You /should/ -- /not/ use this function directly since its type is very @@ -2233,10 +2208,6 @@ unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b) build expr = expr in first (parensM p) $ build (b1, vals) - construct (EAliasedValue i _) = - ERaw noMeta $ const $ aliasedValueIdentToRawSql i - construct (EValueReference i i') = - ERaw noMeta $ const $ valueReferenceToRawSql i i' {-# INLINE unsafeSqlBinOp #-} -- | Similar to 'unsafeSqlBinOp', but may also be applied to @@ -2275,8 +2246,6 @@ unsafeSqlBinOpComposite op sep a b listify v | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = flip (,) [] . f | ERaw _ f <- v = deconstruct . f Parens - | EAliasedValue i _ <- v = deconstruct . (aliasedValueIdentToRawSql i) - | EValueReference i i' <- v = deconstruct . (valueReferenceToRawSql i i') deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals) @@ -2304,8 +2273,6 @@ valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistVa valueToFunctionArg info v = case v of ERaw _ f -> f Never info - EAliasedValue i _ -> aliasedValueIdentToRawSql i info - EValueReference i i' -> valueReferenceToRawSql i i' info -- | (Internal) A raw SQL function. Once again, the same warning -- from 'unsafeSqlBinOp' applies to this function as well. @@ -2343,8 +2310,6 @@ unsafeSqlFunctionParens name arg = let valueToFunctionArgParens v = case v of ERaw _ f -> f p info - EAliasedValue i _ -> aliasedValueIdentToRawSql i info - EValueReference i i' -> valueReferenceToRawSql i i' info (argsTLB, argsVals) = uncommas' $ map valueToFunctionArgParens $ toArgList arg in @@ -2358,8 +2323,6 @@ unsafeSqlCastAs t v = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (v valueToText info = case v of ERaw _ f -> f Never info - EAliasedValue i _ -> aliasedValueIdentToRawSql i info - EValueReference i i' -> valueReferenceToRawSql i i' info -- | (Internal) This class allows 'unsafeSqlFunction' to work with different -- numbers of arguments; specifically it allows providing arguments to a sql @@ -2491,8 +2454,6 @@ instance ( UnsafeSqlFunctionArgument a -- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) veryUnsafeCoerceSqlExprValue (ERaw m f) = ERaw m f -veryUnsafeCoerceSqlExprValue (EAliasedValue i v) = EAliasedValue i (veryUnsafeCoerceSqlExprValue v) -veryUnsafeCoerceSqlExprValue (EValueReference i i') = EValueReference i i' -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList @@ -2928,33 +2889,21 @@ makeFrom info mode fs = ret fromKind FullOuterJoinKind = " FULL OUTER JOIN " makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info) - makeOnClause (EAliasedValue _ _) = throw (AliasedValueErr MakeOnClauseError) - makeOnClause (EValueReference _ _) = throw (AliasedValueErr MakeOnClauseError) mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException mkExc (ERaw _ f) = OnClauseWithoutMatchingJoinException $ TL.unpack $ TLB.toLazyText $ fst (f Never info) - mkExc (EAliasedValue _ _) = throw (AliasedValueErr MakeExcError) - mkExc (EValueReference _ _) = throw (AliasedValueErr MakeExcError) makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue]) makeSet _ [] = mempty makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os where mk (SetClause (ERaw _ f)) = [f Never info] - mk (SetClause (EAliasedValue i _)) = [aliasedValueIdentToRawSql i info] - mk (SetClause (EValueReference i i')) = [valueReferenceToRawSql i i' info] makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) -makeWhere _ NoWhere = mempty -makeWhere info (Where v) = first ("\nWHERE " <>) $ x info - where - x = - case v of - ERaw _ f -> f Never - EAliasedValue i _ -> aliasedValueIdentToRawSql i - EValueReference i i' -> valueReferenceToRawSql i i' +makeWhere _ NoWhere = mempty +makeWhere info (Where (ERaw _ f)) = first ("\nWHERE " <>) $ f Never info makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue]) makeGroupBy _ (GroupBy []) = (mempty, []) @@ -2965,18 +2914,10 @@ makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build match :: SomeValue -> (TLB.Builder, [PersistValue]) match (SomeValue (ERaw _ f)) = f Never info - match (SomeValue (EAliasedValue i _)) = aliasedValueIdentToRawSql i info - match (SomeValue (EValueReference i i')) = valueReferenceToRawSql i i' info makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue]) makeHaving _ NoWhere = mempty -makeHaving info (Where v) = first ("\nHAVING " <>) $ x info - where - x = - case v of - ERaw _ f -> f Never - EAliasedValue i _ -> aliasedValueIdentToRawSql i - EValueReference i i' -> valueReferenceToRawSql i i' +makeHaving info (Where (ERaw _ f)) = first ("\nHAVING " <>) $ f Never info -- makeHaving, makeWhere and makeOrderBy makeOrderByNoNewline @@ -2994,8 +2935,6 @@ makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk let x = case v of ERaw _ f -> f Never - EAliasedValue i _ -> aliasedValueIdentToRawSql i - EValueReference i i' -> valueReferenceToRawSql i i' in [ first (<> orderByType t) $ x info ] mk EOrderRandom = [first (<> "RANDOM()") mempty] @@ -3161,12 +3100,8 @@ materializeExpr info v | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = let bs = f info in (uncommas $ map (parensM Parens) bs, []) - | ERaw _ f <- v = f Parens info -materializeExpr info (EAliasedValue ident x) = - let (b, vals) = materializeExpr info x - in (b <> " AS " <> (useIdent info ident), vals) -materializeExpr info (EValueReference sourceIdent columnIdent) = - valueReferenceToRawSql sourceIdent columnIdent info + | ERaw m f <- v = f Never info + -- | You may return tuples (up to 16-tuples) and tuples of tuples -- from a 'select' query. @@ -3692,11 +3627,6 @@ renderExpr sqlBackend e = case e of ERaw _ mkBuilderValues -> let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState) in (builderToText builder) - EAliasedValue i _ -> - builderToText $ useIdent (sqlBackend, initialIdentState) i - EValueReference i i' -> - let (builder, _) = valueReferenceToRawSql i i' (sqlBackend, initialIdentState) - in (builderToText builder) -- | An exception thrown by 'RenderExpr' - it's not designed to handle composite -- keys, and will blow up if you give it one. From 4dc58ec1b82551ba054be8fc07e0b8cb51950d2a Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 17 Jan 2021 18:26:00 -0600 Subject: [PATCH 03/11] Remove EList and EEmptyList; ERaw is now technically possible in each case since it is generalized to all --- src/Database/Esqueleto/Internal/Internal.hs | 36 ++++++++++----------- test/Common/Test.hs | 15 +++++---- 2 files changed, 27 insertions(+), 24 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index f57c5d0..8460c73 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -24,6 +24,7 @@ module Database.Esqueleto.Internal.Internal where import Control.Applicative ((<|>)) +import Data.Coerce (coerce) import Control.Arrow (first, (***)) import Control.Exception (Exception, throw, throwIO) import Control.Monad (MonadPlus(..), guard, void) @@ -887,12 +888,13 @@ castString = veryUnsafeCoerceSqlExprValue -- | Execute a subquery @SELECT@ in an SqlExpression. Returns a -- list of values. subList_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (ValueList a) -subList_select = EList . sub_select +subList_select query = ERaw noMeta $ \_ info -> first parens $ toRawSql SELECT info query + -- | Lift a list of constant value from Haskell-land to the query. valList :: PersistField typ => [typ] -> SqlExpr (ValueList typ) -valList [] = EEmptyList -valList vals = EList $ ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), map toPersistValue vals ) +valList [] = ERaw noMeta $ \_ _ -> ("()", []) +valList vals = ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ vals)), map toPersistValue vals ) -- | Same as 'just' but for 'ValueList'. Most of the time you -- won't need it, though, because you can use 'just' from @@ -900,8 +902,7 @@ valList vals = EList $ ERaw noMeta $ \p -> const (parensM p (uncommas ("?" <$ va -- -- @since 2.2.12 justList :: SqlExpr (ValueList typ) -> SqlExpr (ValueList (Maybe typ)) -justList EEmptyList = EEmptyList -justList (EList v) = EList (just v) +justList (ERaw m f) = ERaw m f -- | @IN@ operator. For example if you want to select all @Person@s by a list -- of IDs: @@ -923,11 +924,19 @@ justList (EList v) = EList (just v) -- -- Where @personIds@ is of type @[Key Person]@. in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) -v `in_` e = ifNotEmptyList e False $ unsafeSqlBinOp " IN " v (veryUnsafeCoerceSqlExprValueList e) +(ERaw _ v) `in_` (ERaw _ list) = + ERaw noMeta $ \p info -> + let (b1, vals1) = v Parens info + (b2, vals2) = list Parens info + in (b1 <> " IN " <> b2, vals1 <> vals2) -- | @NOT IN@ operator. notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) -v `notIn` e = ifNotEmptyList e True $ unsafeSqlBinOp " NOT IN " v (veryUnsafeCoerceSqlExprValueList e) +(ERaw _ v) `notIn` (ERaw _ list) = + ERaw noMeta $ \p info -> + let (b1, vals1) = v Parens info + (b2, vals2) = list Parens info + in (b1 <> " NOT IN " <> b2, vals1 <> vals2) -- | @EXISTS@ operator. For example: -- @@ -2034,7 +2043,7 @@ data SqlExpr a where -- connection (mainly for escaping names) and returns both an -- string ('TLB.Builder') and a list of values to be -- interpolated by the SQL backend. - ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Value a) + ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr a -- A composite key. -- @@ -2077,10 +2086,6 @@ data SqlExpr a where -- impossible, e.g., for 'val' to disambiguate between these -- uses. - -- 'EList' and 'EEmptyList' are used by list operators. - EList :: SqlExpr (Value a) -> SqlExpr (ValueList a) - EEmptyList :: SqlExpr (ValueList a) - -- A 'SqlExpr' accepted only by 'orderBy'. EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy @@ -2141,10 +2146,6 @@ existsHelper = sub SELECT . (>> return true) true :: SqlExpr (Value Bool) true = val True -ifNotEmptyList :: SqlExpr (ValueList a) -> Bool -> SqlExpr (Value Bool) -> SqlExpr (Value Bool) -ifNotEmptyList EEmptyList b _ = val b -ifNotEmptyList (EList _) _ x = x - -- | (Internal) Create a case statement. -- -- Since: 2.1.1 @@ -2459,8 +2460,7 @@ veryUnsafeCoerceSqlExprValue (ERaw m f) = ERaw m f -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) -veryUnsafeCoerceSqlExprValueList (EList v) = v -veryUnsafeCoerceSqlExprValueList EEmptyList = throw (UnexpectedCaseErr EmptySqlExprValueList) +veryUnsafeCoerceSqlExprValueList (ERaw m f) = ERaw m f ---------------------------------------------------------------------- diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 1dcb918..45fb92a 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -389,7 +389,8 @@ testSubSelect run = do v `shouldBe` [Value 1] describe "subSelectList" $ do - it "is safe on empty databases as well as good databases" $ do + it "is safe on empty databases as well as good databases" $ run $ do + liftIO $ putStrLn "hello" let query = from $ \n -> do where_ $ n ^. NumbersInt `in_` do @@ -398,16 +399,18 @@ testSubSelect run = do where_ $ n' ^. NumbersInt >=. val 3 pure (n' ^. NumbersInt) pure n - - empty <- run $ do + empty <- do + liftIO . print =<< renderQuerySelect query select query + liftIO $ putStrLn "goodbye" - full <- run $ do + full <- do setup select query - empty `shouldBe` [] - full `shouldSatisfy` (not . null) + liftIO $ do + empty `shouldBe` [] + full `shouldSatisfy` (not . null) describe "subSelectMaybe" $ do it "is equivalent to joinV . subSelect" $ do From f77134e78856aa7dea13230c5fada183f9121094 Mon Sep 17 00:00:00 2001 From: belevy Date: Mon, 18 Jan 2021 22:21:56 -0600 Subject: [PATCH 04/11] Remove entity specific constructors from SqlExpr --- src/Database/Esqueleto/Experimental/From.hs | 2 +- .../Esqueleto/Experimental/ToAlias.hs | 33 ++-- .../Experimental/ToAliasReference.hs | 27 ++-- .../Esqueleto/Experimental/ToMaybe.hs | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 127 +++++++--------- src/Database/Esqueleto/Internal/Sql.hs | 31 ++-- src/Database/Esqueleto/PostgreSQL.hs | 45 +++--- test/Common/Test.hs | 143 ++++++++---------- 8 files changed, 190 insertions(+), 220 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs index 085ff9d..2c0cef8 100644 --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/src/Database/Esqueleto/Experimental/From.hs @@ -52,7 +52,7 @@ instance PersistEntity a => From (Table a) where runFrom e@Table = do let ed = entityDef $ getVal e ident <- newIdentFor (entityDB ed) - let entity = EEntity ident + let entity = unsafeSqlEntity ident pure $ (entity, FromStart ident ed) where getVal :: Table ent -> Proxy ent diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index fdb9430..39f927a 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -1,13 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAlias where -import Database.Esqueleto.Internal.Internal hiding (From, - from, on) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Internal.Internal hiding (From, from, on) +import Database.Esqueleto.Internal.PersistentImport {-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} type ToAliasT a = a @@ -17,22 +16,26 @@ class ToAlias a where toAlias :: a -> SqlQuery a instance ToAlias (SqlExpr (Value a)) where - toAlias (ERaw m f) - | Nothing <- sqlExprMetaAlias m = do - ident <- newIdentFor (DBName "v") - pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> - let (b, v) = f Never info - in (b <> " AS " <> useIdent info ident, []) + toAlias (ERaw m f) = + case sqlExprMetaAlias m of + Just _ -> pure $ ERaw m f + Nothing -> do + ident <- newIdentFor (DBName "v") + pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> + let (b, v) = f Never info + in (b <> " AS " <> useIdent info ident, []) + instance ToAlias (SqlExpr (Entity a)) where - toAlias v@(EAliasedEntityReference _ _) = pure v - toAlias v@(EAliasedEntity _ _) = pure v - toAlias (EEntity tableIdent) = do + toAlias (ERaw m f) = do ident <- newIdentFor (DBName "v") - pure $ EAliasedEntity ident tableIdent + pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f instance ToAlias (SqlExpr (Maybe (Entity a))) where - toAlias (EMaybe e) = EMaybe <$> toAlias e + -- FIXME: Code duplication because the compiler doesnt like half final encoding + toAlias (ERaw m f) = do + ident <- newIdentFor (DBName "v") + pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f instance (ToAlias a, ToAlias b) => ToAlias (a,b) where toAlias (a,b) = (,) <$> toAlias a <*> toAlias b diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index 568758c..f39a37d 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -1,14 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAliasReference where -import Database.Esqueleto.Experimental.ToAlias -import Database.Esqueleto.Internal.Internal hiding (From, - from, on) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Internal.Internal hiding (From, 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." #-} type ToAliasReferenceT a = a @@ -19,16 +18,24 @@ class ToAliasReference a where instance ToAliasReference (SqlExpr (Value a)) where toAliasReference aliasSource (ERaw m _) - | Just alias <- sqlExprMetaAlias m = pure $ ERaw noMeta $ \p info -> + | Just alias <- sqlExprMetaAlias m = pure $ ERaw m $ \_ info -> (useIdent info aliasSource <> "." <> useIdent info alias, []) + toAliasReference _ e = pure e instance ToAliasReference (SqlExpr (Entity a)) where - toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident - toAliasReference _ e@(EEntity _) = toAlias e - toAliasReference s (EAliasedEntityReference _ b) = pure $ EAliasedEntityReference s b + toAliasReference aliasSource (ERaw m _) + | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = + pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> + (useIdent info aliasSource, []) + toAliasReference _ e = pure e instance ToAliasReference (SqlExpr (Maybe (Entity a))) where - toAliasReference s (EMaybe e) = EMaybe <$> toAliasReference s e + -- FIXME: Code duplication because the compiler doesnt like half final encoding + toAliasReference aliasSource (ERaw m f) + | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = + pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> + (useIdent info aliasSource, []) + toAliasReference s e = pure e instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs index cc1a0f8..0677bfb 100644 --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/src/Database/Esqueleto/Experimental/ToMaybe.hs @@ -21,7 +21,7 @@ instance ToMaybe (SqlExpr (Maybe a)) where instance ToMaybe (SqlExpr (Entity a)) where type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a)) - toMaybe = EMaybe + toMaybe (ERaw f m) = (ERaw f m) instance ToMaybe (SqlExpr (Value a)) where type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a))) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 8460c73..52127c7 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -88,7 +88,7 @@ fromStart fromStart = do let ed = entityDef (Proxy :: Proxy a) ident <- newIdentFor (entityDB ed) - let ret = EEntity ident + let ret = unsafeSqlEntity ident f' = FromStart ident ed return (EPreprocessedFrom ret f') @@ -103,7 +103,7 @@ fromStartMaybe = maybelize <$> fromStart maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) - maybelize (EPreprocessedFrom ret f') = EPreprocessedFrom (EMaybe ret) f' + maybelize (EPreprocessedFrom (ERaw m f) f') = EPreprocessedFrom (ERaw m f) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -527,9 +527,12 @@ subSelectUnsafe = sub SELECT => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ) -(EAliasedEntityReference source base) ^. field = - ERaw noMeta $ \_ info -> - (useIdent info source <> "." <> useIdent info (aliasedEntityColumnIdent base fieldDef), []) +e ^. field + | isIdField field = idFieldValue + | ERaw m f <- e, Just alias <- sqlExprMetaAlias m = + ERaw noMeta $ \_ info -> + f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), []) + | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) where fieldDef = if isIdField field then @@ -537,13 +540,6 @@ subSelectUnsafe = sub SELECT head $ entityKeyFields ed else persistFieldDef field - - ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) - -e ^. field - | isIdField field = idFieldValue - | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) - where idFieldValue = case entityKeyFields ed of idField:[] -> @@ -558,29 +554,19 @@ e ^. field ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) dot info fieldDef = - useIdent info sourceIdent <> "." <> fieldIdent + sourceIdent info <> "." <> fieldIdent where sourceIdent = case e of - EEntity ident -> ident - EAliasedEntity baseI _ -> baseI - EAliasedEntityReference a b -> - error $ unwords - [ "Used (^.) with an EAliasedEntityReference." - , "Please file this as an Esqueleto bug." - , "EAliasedEntityReference", show a, show b - ] + ERaw _ f -> fmap fst $ f Never fieldIdent = case e of - EEntity _ -> fromDBName info (fieldDB fieldDef) - EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef - EAliasedEntityReference a b -> - error $ unwords - [ "Used (^.) with an EAliasedEntityReference." - , "Please file this as an Esqueleto bug." - , "EAliasedEntityReference", show a, show b - ] - + ERaw m f -> + case sqlExprMetaAlias m of + Just baseI -> + useIdent info $ aliasedEntityColumnIdent baseI fieldDef + Nothing -> + fromDBName info (fieldDB fieldDef) -- | Project an SqlExpression that may be null, guarding against null cases. withNonNull @@ -598,7 +584,7 @@ withNonNull field f = do => SqlExpr (Maybe (Entity val)) -> EntityField val typ -> SqlExpr (Value (Maybe typ)) -EMaybe r ?. field = just (r ^. field) +ERaw m f ?. field = just (ERaw m f ^. field) -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> SqlExpr (Value typ) @@ -2012,12 +1998,14 @@ useIdent info (I ident) = fromDBName info $ DBName ident data SqlExprMeta = SqlExprMeta { sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) , sqlExprMetaAlias :: Maybe Ident + , sqlExprMetaIsReference :: Bool } noMeta :: SqlExprMeta noMeta = SqlExprMeta { sqlExprMetaCompositeFields = Nothing , sqlExprMetaAlias = Nothing + , sqlExprMetaIsReference = False } hasCompositeKeyMeta :: SqlExprMeta -> Bool @@ -2028,16 +2016,6 @@ hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields -- There are many comments describing the constructors of this -- data type. However, Haddock doesn't like GADTs, so you'll have to read them by hitting \"Source\". data SqlExpr a where - -- An entity, created by 'from' (cf. 'fromStart'). - EEntity :: Ident -> SqlExpr (Entity val) - -- Base Table - EAliasedEntity :: Ident -> Ident -> SqlExpr (Entity val) - -- Source Base - EAliasedEntityReference :: Ident -> Ident -> SqlExpr (Entity val) - - -- Just a tag stating that something is nullable. - EMaybe :: SqlExpr a -> SqlExpr (Maybe a) - -- Raw expression: states whether parenthesis are needed -- around this expression, and takes information about the SQL -- connection (mainly for escaping names) and returns both an @@ -2270,6 +2248,10 @@ unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty) {-# INLINE unsafeSqlValue #-} +unsafeSqlEntity :: PersistEntity ent => Ident -> SqlExpr (Entity ent) +unsafeSqlEntity ident = ERaw noMeta $ \_ info -> + (useIdent info ident, []) + valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) valueToFunctionArg info v = case v of @@ -3035,37 +3017,36 @@ unescapedColumnNames ent = -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where - sqlSelectCols info expr@(EEntity ident) = ret - where - process ed = uncommas $ - map ((name <>) . TLB.fromText) $ - entityColumnNames ed (fst info) - -- 'name' is the biggest difference between 'RawSql' and - -- 'SqlSelect'. We automatically create names for tables - -- (since it's not the user who's writing the FROM - -- clause), while 'rawSql' assumes that it's just the - -- name of the table (which doesn't allow self-joins, for - -- example). - name = useIdent info ident <> "." - ret = let ed = entityDef $ getEntityVal $ return expr - in (process ed, mempty) - sqlSelectCols info expr@(EAliasedEntity aliasIdent tableIdent) = ret - where - process ed = uncommas $ - map ((name <>) . aliasName) $ - unescapedColumnNames ed - aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName aliasIdent info (unDBName columnName) - name = useIdent info tableIdent <> "." - ret = let ed = entityDef $ getEntityVal $ return expr - in (process ed, mempty) - sqlSelectCols info expr@(EAliasedEntityReference sourceIdent baseIdent) = ret - where - process ed = uncommas $ - map ((name <>) . aliasedColumnName baseIdent info . unDBName) $ - unescapedColumnNames ed - name = useIdent info sourceIdent <> "." - ret = let ed = entityDef $ getEntityVal $ return expr - in (process ed, mempty) + sqlSelectCols info expr@(ERaw m f) + | Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = + let process ed = uncommas $ + map ((name <>) . aliasName) $ + unescapedColumnNames ed + aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName baseIdent info (unDBName columnName) + name = fst (f Never info) <> "." + ed = entityDef $ getEntityVal $ return expr + in (process ed, mempty) + | Just baseIdent <- sqlExprMetaAlias m, True <- sqlExprMetaIsReference m = + let process ed = uncommas $ + map ((name <>) . aliasedColumnName baseIdent info . unDBName) $ + unescapedColumnNames ed + name = fst (f Never info) <> "." + ed = entityDef $ getEntityVal $ return expr + in (process ed, mempty) + | otherwise = + let process ed = uncommas $ + map ((name <>) . TLB.fromText) $ + entityColumnNames ed (fst info) + -- 'name' is the biggest difference between 'RawSql' and + -- 'SqlSelect'. We automatically create names for tables + -- (since it's not the user who's writing the FROM + -- clause), while 'rawSql' assumes that it's just the + -- name of the table (which doesn't allow self-joins, for + -- example). + name = fst (f Never info) <> "." + ed = entityDef $ getEntityVal $ return expr + in (process ed, mempty) + sqlSelectColCount = entityColumnCount . entityDef . getEntityVal sqlSelectProcessRow = parseEntityValues ed where @@ -3076,7 +3057,7 @@ getEntityVal = const Proxy -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent + sqlSelectCols info (ERaw m f) = sqlSelectCols info (ERaw m f :: SqlExpr (Entity a)) sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 39e895b..2af0009 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | This is an internal module, anything exported by this module @@ -38,6 +38,7 @@ module Database.Esqueleto.Internal.Sql , unsafeSqlCase , unsafeSqlBinOp , unsafeSqlValue + , unsafeSqlEntity , unsafeSqlCastAs , unsafeSqlFunction , unsafeSqlExtractSubField @@ -74,4 +75,4 @@ module Database.Esqueleto.Internal.Sql , associateJoin ) where -import Database.Esqueleto.Internal.Internal +import Database.Esqueleto.Internal.Internal diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 7262dce..01847e6 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module contain PostgreSQL-specific functions. @@ -31,23 +31,22 @@ module Database.Esqueleto.PostgreSQL ) where #if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup +import Data.Semigroup #endif -import Control.Arrow (first, (***)) -import Control.Exception (throw) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (..)) -import qualified Control.Monad.Trans.Reader as R -import Data.Int (Int64) -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Proxy (Proxy (..)) -import qualified Data.Text.Internal.Builder as TLB -import Data.Time.Clock (UTCTime) -import Database.Esqueleto.Internal.Internal hiding (random_) -import Database.Esqueleto.Internal.PersistentImport hiding (upsert, - upsertBy) -import Database.Persist.Class (OnlyOneUniqueKey) +import Control.Arrow (first, (***)) +import Control.Exception (throw) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Control.Monad.Trans.Reader as R +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy (Proxy(..)) +import qualified Data.Text.Internal.Builder as TLB +import Data.Time.Clock (UTCTime) +import Database.Esqueleto.Internal.Internal hiding (random_) +import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) +import Database.Persist.Class (OnlyOneUniqueKey) -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -306,9 +305,9 @@ insertSelectWithConflictCount unique query conflictQuery = do proxy = Proxy updates = conflictQuery entCurrent entExcluded combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) - entExcluded = EEntity $ I "excluded" + entExcluded = unsafeSqlEntity (I "excluded") tableName = unDBName . entityDB . entityDef - entCurrent = EEntity $ I (tableName proxy) + entCurrent = unsafeSqlEntity (I (tableName proxy)) uniqueDef = toUniqueDef unique constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 45fb92a..4f1fb4b 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -62,41 +62,37 @@ module Common.Test , Key(..) ) where -import Control.Monad (forM_, replicateM, - replicateM_, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Reader (ask) -import Data.Either -import Data.Time +import Control.Monad (forM_, replicateM, replicateM_, void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Reader (ask) +import Data.Either +import Data.Time #if __GLASGOW_HASKELL__ >= 806 -import Control.Monad.Fail (MonadFail) +import Control.Monad.Fail (MonadFail) #endif -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (MonadLogger (..), - NoLoggingT, - runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Data.Attoparsec.Text as AP -import Data.Char (toLower, toUpper) -import Data.Monoid ((<>)) -import Database.Esqueleto -import Database.Esqueleto.Experimental hiding (from, on) -import qualified Database.Esqueleto.Experimental as Experimental -import Database.Persist.TH -import Test.Hspec -import UnliftIO +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT) +import qualified Data.Attoparsec.Text as AP +import Data.Char (toLower, toUpper) +import Data.Monoid ((<>)) +import Database.Esqueleto +import Database.Esqueleto.Experimental hiding (from, on) +import qualified Database.Esqueleto.Experimental as Experimental +import Database.Persist.TH +import Test.Hspec +import UnliftIO -import Data.Conduit (ConduitT, runConduit, - (.|)) -import qualified Data.Conduit.List as CL -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Text as Text -import qualified Data.Text.Internal.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB +import Data.Conduit (ConduitT, runConduit, (.|)) +import qualified Data.Conduit.List as CL +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Text as Text +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.Sql as EI -import qualified UnliftIO.Resource as R +import qualified Database.Esqueleto.Internal.Sql as EI +import qualified UnliftIO.Resource as R -- Test schema share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| @@ -390,7 +386,6 @@ testSubSelect run = do describe "subSelectList" $ do it "is safe on empty databases as well as good databases" $ run $ do - liftIO $ putStrLn "hello" let query = from $ \n -> do where_ $ n ^. NumbersInt `in_` do @@ -399,10 +394,7 @@ testSubSelect run = do where_ $ n' ^. NumbersInt >=. val 3 pure (n' ^. NumbersInt) pure n - empty <- do - liftIO . print =<< renderQuerySelect query - select query - liftIO $ putStrLn "goodbye" + empty <- select query full <- do setup @@ -895,12 +887,15 @@ testSelectSubQuery run = describe "select subquery" $ do l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int]) let l1WithDeeds = do d <- l1Deeds pure (l1e, Just d) - ret <- select $ Experimental.from $ do - (lords :& deeds) <- - Experimental.from $ Table @Lord - `LeftOuterJoin` Table @Deed - `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) - pure (lords, deeds) + let q = Experimental.from $ do + (lords :& deeds) <- + Experimental.from $ Table @Lord + `LeftOuterJoin` Table @Deed + `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) + pure (lords, deeds) + + liftIO . print =<< renderQuerySelect q + ret <- select q liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds) it "lets you order by alias" $ run $ do @@ -1847,9 +1842,10 @@ testRenderSql run = do (c, expr) <- run $ do conn <- ask let Right c = P.mkEscapeChar conn + let user = EI.unsafeSqlEntity (EI.I "user") + blogPost = EI.unsafeSqlEntity (EI.I "blog_post") pure $ (,) c $ EI.renderExpr conn $ - EI.EEntity (EI.I "user") ^. PersonId - ==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId + user ^. PersonId ==. blogPost ^. BlogPostAuthorId expr `shouldBe` Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] @@ -1861,23 +1857,6 @@ testRenderSql run = do expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1)) expr `shouldBe` "? = ?" - describe "EEntity Ident behavior" $ do - let render :: SqlExpr (Entity val) -> Text.Text - render (EI.EEntity (EI.I ident)) = ident - render _ = error "guess we gotta handle this in the test suite now" - it "renders sensibly" $ run $ do - _ <- insert $ Foo 2 - _ <- insert $ Foo 3 - _ <- insert $ Person "hello" Nothing Nothing 3 - results <- select $ - from $ \(a `LeftOuterJoin` b) -> do - on $ a ^. FooName ==. b ^. PersonFavNum - pure (val (render a), val (render b)) - liftIO $ - head results - `shouldBe` - (Value "Foo", Value "Person") - describe "ExprParser" $ do let parse parser = AP.parseOnly (parser '#') describe "parseEscapedChars" $ do From 2da0526b9069f7a513726f244cbb3be0a7f95fb2 Mon Sep 17 00:00:00 2001 From: belevy Date: Tue, 19 Jan 2021 09:46:02 -0600 Subject: [PATCH 05/11] Remove EOrderBy, EDistinctOn; Change PreprocessedFrom a to just be an independent datatype --- src/Database/Esqueleto/Internal/Internal.hs | 159 +++++++++----------- 1 file changed, 75 insertions(+), 84 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 52127c7..b47b958 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -84,35 +84,35 @@ fromStart ( PersistEntity a , BackendCompatible SqlBackend (PersistEntityBackend a) ) - => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) + => SqlQuery (PreprocessedFrom (SqlExpr (Entity a))) fromStart = do let ed = entityDef (Proxy :: Proxy a) ident <- newIdentFor (entityDB ed) let ret = unsafeSqlEntity ident f' = FromStart ident ed - return (EPreprocessedFrom ret f') + return (PreprocessedFrom ret f') -- | (Internal) Same as 'fromStart', but entity may be missing. fromStartMaybe :: ( PersistEntity a , BackendCompatible SqlBackend (PersistEntityBackend a) ) - => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))) + => SqlQuery (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) fromStartMaybe = maybelize <$> fromStart where maybelize - :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) - -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) - maybelize (EPreprocessedFrom (ERaw m f) f') = EPreprocessedFrom (ERaw m f) f' + :: PreprocessedFrom (SqlExpr (Entity a)) + -> PreprocessedFrom (SqlExpr (Maybe (Entity a))) + maybelize (PreprocessedFrom (ERaw m f) f') = PreprocessedFrom (ERaw m f) f' -- | (Internal) Do a @JOIN@. fromJoin :: IsJoinKind join - => SqlExpr (PreprocessedFrom a) - -> SqlExpr (PreprocessedFrom b) - -> SqlQuery (SqlExpr (PreprocessedFrom (join a b))) -fromJoin (EPreprocessedFrom lhsRet lhsFrom) - (EPreprocessedFrom rhsRet rhsFrom) = Q $ do + => PreprocessedFrom a + -> PreprocessedFrom b + -> SqlQuery (PreprocessedFrom (join a b)) +fromJoin (PreprocessedFrom lhsRet lhsFrom) + (PreprocessedFrom rhsRet rhsFrom) = Q $ do let ret = smartJoin lhsRet rhsRet from' = FromJoin @@ -120,13 +120,13 @@ fromJoin (EPreprocessedFrom lhsRet lhsFrom) (reifyJoinKind ret) -- JOIN rhsFrom -- RHS Nothing -- ON - return (EPreprocessedFrom ret from') + return (PreprocessedFrom ret from') -- | (Internal) Finish a @JOIN@. fromFinish - :: SqlExpr (PreprocessedFrom a) + :: PreprocessedFrom a -> SqlQuery a -fromFinish (EPreprocessedFrom ret f') = Q $ do +fromFinish (PreprocessedFrom ret f') = Q $ do W.tell mempty { sdFromClause = [f'] } return ret @@ -250,11 +250,22 @@ orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs } -- | Ascending order of this field or SqlExpression. asc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy -asc = EOrderBy ASC +asc = orderByExpr " ASC" -- | Descending order of this field or SqlExpression. desc :: PersistField a => SqlExpr (Value a) -> SqlExpr OrderBy -desc = EOrderBy DESC +desc = orderByExpr " DESC" + +orderByExpr :: TLB.Builder -> SqlExpr (Value a) -> SqlExpr OrderBy +orderByExpr orderByType (ERaw m f) + | Just fields <- sqlExprMetaCompositeFields m = + ERaw noMeta $ \_ info -> + let fs = fields info + vals = repeat [] + in uncommas' $ zip (map (<> orderByType) fs) vals + | otherwise = + ERaw noMeta $ \_ info -> + first (<> orderByType) $ f Never info -- | @LIMIT@. Limit the number of returned rows. limit :: Int64 -> SqlQuery () @@ -326,7 +337,7 @@ distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) -- -- @since 2.2.4 don :: SqlExpr (Value a) -> SqlExpr DistinctOn -don = EDistinctOn +don (ERaw m f) = ERaw m f -- | A convenience function that calls both 'distinctOn' and -- 'orderBy'. In other words, @@ -352,7 +363,7 @@ distinctOnOrderBy exprs act = act where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn - toDistinctOn (EOrderBy _ f) = EDistinctOn f + toDistinctOn (ERaw m f) = ERaw m f toDistinctOn EOrderRandom = error "We can't select distinct by a random order!" @@ -1362,9 +1373,6 @@ data OnClauseWithoutMatchingJoinException = instance Exception OnClauseWithoutMatchingJoinException --- | (Internal) Phantom type used to process 'from' (see 'fromStart'). -data PreprocessedFrom a - -- | Phantom type used by 'orderBy', 'asc' and 'desc'. data OrderBy @@ -1606,7 +1614,7 @@ instance -- | (Internal) Class that implements the @JOIN@ 'from' magic -- (see 'fromStart'). class FromPreprocess a where - fromPreprocess :: SqlQuery (SqlExpr (PreprocessedFrom a)) + fromPreprocess :: SqlQuery (PreprocessedFrom a) instance (PersistEntity val, BackendCompatible SqlBackend (PersistEntityBackend val)) @@ -1996,7 +2004,47 @@ useIdent :: IdentInfo -> Ident -> TLB.Builder useIdent info (I ident) = fromDBName info $ DBName ident data SqlExprMeta = SqlExprMeta - { sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) + { -- A composite key. + -- + -- Persistent uses the same 'PersistList' constructor for both + -- fields which are (homogeneous) lists of values and the + -- (probably heterogeneous) values of a composite primary key. + -- + -- We need to treat composite keys as fields. For example, we + -- have to support using ==., otherwise you wouldn't be able to + -- join. OTOH, lists of values should be treated exactly the + -- same as any other scalar value. + -- + -- In particular, this is valid for persistent via rawSql for + -- an F field that is a list: + -- + -- A.F in ? -- [PersistList [foo, bar]] + -- + -- However, this is not for a composite key entity: + -- + -- A.ID = ? -- [PersistList [foo, bar]] + -- + -- The ID field doesn't exist on the DB for a composite key + -- table, it exists only on the Haskell side. Those variations + -- also don't work: + -- + -- (A.KeyA, A.KeyB) = ? -- [PersistList [foo, bar]] + -- [A.KeyA, A.KeyB] = ? -- [PersistList [foo, bar]] + -- + -- We have to generate: + -- + -- A.KeyA = ? AND A.KeyB = ? -- [foo, bar] + -- + -- Note that the PersistList had to be deconstructed into its + -- components. + -- + -- In order to disambiguate behaviors, this constructor is used + -- /only/ to represent a composite field access. It does not + -- represent a 'PersistList', not even if the 'PersistList' is + -- used in the context of a composite key. That's because it's + -- impossible, e.g., for 'val' to disambiguate between these + -- uses. + sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) , sqlExprMetaAlias :: Maybe Ident , sqlExprMetaIsReference :: Bool } @@ -2023,65 +2071,17 @@ data SqlExpr a where -- interpolated by the SQL backend. ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr a - -- A composite key. - -- - -- Persistent uses the same 'PersistList' constructor for both - -- fields which are (homogeneous) lists of values and the - -- (probably heterogeneous) values of a composite primary key. - -- - -- We need to treat composite keys as fields. For example, we - -- have to support using ==., otherwise you wouldn't be able to - -- join. OTOH, lists of values should be treated exactly the - -- same as any other scalar value. - -- - -- In particular, this is valid for persistent via rawSql for - -- an F field that is a list: - -- - -- A.F in ? -- [PersistList [foo, bar]] - -- - -- However, this is not for a composite key entity: - -- - -- A.ID = ? -- [PersistList [foo, bar]] - -- - -- The ID field doesn't exist on the DB for a composite key - -- table, it exists only on the Haskell side. Those variations - -- also don't work: - -- - -- (A.KeyA, A.KeyB) = ? -- [PersistList [foo, bar]] - -- [A.KeyA, A.KeyB] = ? -- [PersistList [foo, bar]] - -- - -- We have to generate: - -- - -- A.KeyA = ? AND A.KeyB = ? -- [foo, bar] - -- - -- Note that the PersistList had to be deconstructed into its - -- components. - -- - -- In order to disambiguate behaviors, this constructor is used - -- /only/ to represent a composite field access. It does not - -- represent a 'PersistList', not even if the 'PersistList' is - -- used in the context of a composite key. That's because it's - -- impossible, e.g., for 'val' to disambiguate between these - -- uses. - - -- A 'SqlExpr' accepted only by 'orderBy'. - EOrderBy :: OrderByType -> SqlExpr (Value a) -> SqlExpr OrderBy - EOrderRandom :: SqlExpr OrderBy - -- A 'SqlExpr' accepted only by 'distinctOn'. - EDistinctOn :: SqlExpr (Value a) -> SqlExpr DistinctOn - -- A 'SqlExpr' accepted only by 'set'. ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) - -- An internal 'SqlExpr' used by the 'from' hack. - EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a) - -- Used by 'insertSelect'. EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal +data PreprocessedFrom a = PreprocessedFrom a FromClause + -- | Phantom type used to mark a @INSERT INTO@ query. data InsertFinal @@ -2812,7 +2812,7 @@ makeSelect info mode_ distinctClause ret = process mode_ first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $ uncommas' (processExpr <$> exprs) where - processExpr (EDistinctOn f) = materializeExpr info f + processExpr (ERaw m f) = materializeExpr info (ERaw m f :: SqlExpr (Value a)) withCols v = v <> sqlSelectCols info ret plain v = (v, []) @@ -2908,16 +2908,7 @@ makeOrderByNoNewline _ [] = mempty makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk os where mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] - mk (EOrderBy t v) - | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = - let fs = f info - vals = repeat [] - in zip (map (<> orderByType t) fs) vals - | otherwise = - let x = - case v of - ERaw _ f -> f Never - in [ first (<> orderByType t) $ x info ] + mk (ERaw _ f) = [f Never info] mk EOrderRandom = [first (<> "RANDOM()") mempty] orderByType ASC = " ASC" From c9eb8455687bfae3f7a02957880b59e2d340a896 Mon Sep 17 00:00:00 2001 From: belevy Date: Tue, 19 Jan 2021 09:51:23 -0600 Subject: [PATCH 06/11] Remove EOrderByRandom, calling distinctOnOrderBy with rand will choke the db but you shouldnt be using rand anyway. distinctOnOrderBy seems dangerous though --- src/Database/Esqueleto/Internal/Internal.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index b47b958..bdfe5e0 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -364,14 +364,12 @@ distinctOnOrderBy exprs act = where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn toDistinctOn (ERaw m f) = ERaw m f - toDistinctOn EOrderRandom = - error "We can't select distinct by a random order!" -- | @ORDER BY random()@ clause. -- -- @since 1.3.10 rand :: SqlExpr OrderBy -rand = EOrderRandom +rand = ERaw noMeta $ \_ _ -> ("RANDOM()", []) -- | @HAVING@. -- @@ -2071,8 +2069,6 @@ data SqlExpr a where -- interpolated by the SQL backend. ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr a - EOrderRandom :: SqlExpr OrderBy - -- A 'SqlExpr' accepted only by 'set'. ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) @@ -2909,7 +2905,6 @@ makeOrderByNoNewline info os = first ("ORDER BY " <>) . uncommas' $ concatMap mk where mk :: OrderByClause -> [(TLB.Builder, [PersistValue])] mk (ERaw _ f) = [f Never info] - mk EOrderRandom = [first (<> "RANDOM()") mempty] orderByType ASC = " ASC" orderByType DESC = " DESC" @@ -2920,8 +2915,6 @@ makeOrderBy info is = let (tlb, vals) = makeOrderByNoNewline info is in ("\n" <> tlb, vals) -{-# DEPRECATED EOrderRandom "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} - makeLimit :: IdentInfo -> LimitClause -> [OrderByClause] -> (TLB.Builder, [PersistValue]) makeLimit (conn, _) (Limit ml mo) orderByClauses = let limitRaw = connLimitOffset conn (v ml, v mo) hasOrderClause "\n" From ec853664aa90ea069c8be2faed3bd71c48cd0001 Mon Sep 17 00:00:00 2001 From: belevy Date: Tue, 19 Jan 2021 12:35:19 -0600 Subject: [PATCH 07/11] Remove ESet --- src/Database/Esqueleto/Internal/Internal.hs | 39 ++++++++++----------- src/Database/Esqueleto/PostgreSQL.hs | 8 ++--- 2 files changed, 23 insertions(+), 24 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index bdfe5e0..fc3b6d0 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -959,24 +959,24 @@ notExists q = ERaw noMeta $ \p info -> -- | @SET@ clause used on @UPDATE@s. Note that while it's not -- a type error to use this function on a @SELECT@, it will -- most certainly result in a runtime error. -set :: PersistEntity val => SqlExpr (Entity val) -> [SqlExpr (Update val)] -> SqlQuery () +set :: PersistEntity val => SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery () set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds } where - apply (ESet f) = SetClause (f ent) + apply f = SetClause (f ent) -(=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> SqlExpr (Value typ) -> SqlExpr (Update val) +(=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> SqlExpr (Value typ) -> (SqlExpr (Entity val) -> SqlExpr Update ) field =. expr = setAux field (const expr) -(+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) +(+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update) field +=. expr = setAux field (\ent -> ent ^. field +. expr) -(-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) +(-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update) field -=. expr = setAux field (\ent -> ent ^. field -. expr) -(*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) +(*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update) field *=. expr = setAux field (\ent -> ent ^. field *. expr) -(/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> SqlExpr (Update val) +(/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> SqlExpr (Value a) -> (SqlExpr (Entity val) -> SqlExpr Update) field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments. @@ -1284,15 +1284,15 @@ toUniqueDef uniqueConstructor = uniqueDef renderUpdates :: (BackendCompatible SqlBackend backend) => backend - -> [SqlExpr (Update val)] + -> [SqlExpr (Entity val) -> SqlExpr Update] -> (TLB.Builder, [PersistValue]) renderUpdates conn = uncommas' . concatMap renderUpdate where - mk :: SqlExpr (Value ()) -> [(TLB.Builder, [PersistValue])] + mk :: SqlExpr Update -> [(TLB.Builder, [PersistValue])] mk (ERaw _ f) = [f Never info] - renderUpdate :: SqlExpr (Update val) -> [(TLB.Builder, [PersistValue])] - renderUpdate (ESet f) = mk (f undefined) -- second parameter of f is always unused + renderUpdate :: (SqlExpr (Entity val) -> SqlExpr Update) -> [(TLB.Builder, [PersistValue])] + renderUpdate f = mk (f undefined) -- second parameter of f is always unused info = (projectBackend conn, initialIdentState) -- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example). @@ -1379,7 +1379,7 @@ data DistinctOn -- | Phantom type for a @SET@ operation on an entity of the given -- type (see 'set' and '(=.)'). -data Update typ +data Update -- | Phantom type used by 'insertSelect'. data Insertion a @@ -1798,7 +1798,7 @@ instance Show FromClause where render' = T.unpack . renderExpr dummy -- | A part of a @SET@ clause. -newtype SetClause = SetClause (SqlExpr (Value ())) +newtype SetClause = SetClause (SqlExpr Update) -- | Collect 'OnClause's on 'FromJoin's. Returns the first -- unmatched 'OnClause's data on error. Returns a list without @@ -2069,9 +2069,6 @@ data SqlExpr a where -- interpolated by the SQL backend. ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr a - -- A 'SqlExpr' accepted only by 'set'. - ESet :: (SqlExpr (Entity val) -> SqlExpr (Value ())) -> SqlExpr (Update val) - -- Used by 'insertSelect'. EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal @@ -2103,10 +2100,12 @@ setAux :: (PersistEntity val, PersistField typ) => EntityField val typ -> (SqlExpr (Entity val) -> SqlExpr (Value typ)) - -> SqlExpr (Update val) -setAux field mkVal = ESet $ \ent -> unsafeSqlBinOp " = " name (mkVal ent) - where - name = ERaw noMeta $ \_ info -> (fieldName info field, mempty) + -> (SqlExpr (Entity val) -> SqlExpr Update) +setAux field value = \ent -> ERaw noMeta $ \_ info -> + let (valueToSet, valueVals) = + case value ent of + ERaw _ valueF -> valueF Parens info + in (fieldName info field <> " = " <> valueToSet, valueVals) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) sub mode query = ERaw noMeta $ \_ info -> first parens $ toRawSql mode info query diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 01847e6..5f5c2b7 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -182,7 +182,7 @@ upsert ) => record -- ^ new record to insert - -> [SqlExpr (Update record)] + -> [SqlExpr (Entity record) -> SqlExpr Update] -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation @@ -200,7 +200,7 @@ upsertBy -- ^ uniqueness constraint to find by -> record -- ^ new record to insert - -> [SqlExpr (Update record)] + -> [SqlExpr (Entity record) -> SqlExpr Update] -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation @@ -276,7 +276,7 @@ insertSelectWithConflict -- a unique "MyUnique 0", "MyUnique undefined" would work as well. -> SqlQuery (SqlExpr (Insertion val)) -- ^ Insert query. - -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) + -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]) -- ^ A list of updates to be applied in case of the constraint being -- violated. The expression takes the current and excluded value to produce -- the updates. @@ -292,7 +292,7 @@ insertSelectWithConflictCount . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val) => a -> SqlQuery (SqlExpr (Insertion val)) - -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)]) + -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update]) -> SqlWriteT m Int64 insertSelectWithConflictCount unique query conflictQuery = do conn <- R.ask From 2f5ae76cbf8e7c00933dcae7a00c86d70b79082b Mon Sep 17 00:00:00 2001 From: belevy Date: Tue, 19 Jan 2021 13:31:26 -0600 Subject: [PATCH 08/11] Remove EInsert and EInsertFinal --- src/Database/Esqueleto/Internal/Internal.hs | 108 ++++++++------------ src/Database/Esqueleto/PostgreSQL.hs | 2 +- 2 files changed, 44 insertions(+), 66 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index fc3b6d0..1f70874 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -103,7 +103,7 @@ fromStartMaybe = maybelize <$> fromStart maybelize :: PreprocessedFrom (SqlExpr (Entity a)) -> PreprocessedFrom (SqlExpr (Maybe (Entity a))) - maybelize (PreprocessedFrom (ERaw m f) f') = PreprocessedFrom (ERaw m f) f' + maybelize (PreprocessedFrom e f') = PreprocessedFrom (coerce e) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -337,7 +337,7 @@ distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) -- -- @since 2.2.4 don :: SqlExpr (Value a) -> SqlExpr DistinctOn -don (ERaw m f) = ERaw m f +don = coerce -- | A convenience function that calls both 'distinctOn' and -- 'orderBy'. In other words, @@ -363,7 +363,7 @@ distinctOnOrderBy exprs act = act where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn - toDistinctOn (ERaw m f) = ERaw m f + toDistinctOn = coerce -- | @ORDER BY random()@ clause. -- @@ -536,9 +536,9 @@ subSelectUnsafe = sub SELECT => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ) -e ^. field +ERaw m f ^. field | isIdField field = idFieldValue - | ERaw m f <- e, Just alias <- sqlExprMetaAlias m = + | Just alias <- sqlExprMetaAlias m = ERaw noMeta $ \_ info -> f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), []) | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) @@ -565,17 +565,12 @@ e ^. field dot info fieldDef = sourceIdent info <> "." <> fieldIdent where - sourceIdent = - case e of - ERaw _ f -> fmap fst $ f Never - fieldIdent = - case e of - ERaw m f -> - case sqlExprMetaAlias m of - Just baseI -> - useIdent info $ aliasedEntityColumnIdent baseI fieldDef - Nothing -> - fromDBName info (fieldDB fieldDef) + sourceIdent = fmap fst $ f Never + fieldIdent + | Just baseI <- sqlExprMetaAlias m = + useIdent info $ aliasedEntityColumnIdent baseI fieldDef + | otherwise = + fromDBName info (fieldDB fieldDef) -- | Project an SqlExpression that may be null, guarding against null cases. withNonNull @@ -981,20 +976,15 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr) -- | Apply a 'PersistField' constructor to @SqlExpr Value@ arguments. (<#) :: (a -> b) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(<#) _ (ERaw _ f) = EInsert Proxy (f Never) +(<#) _ (ERaw _ f) = ERaw noMeta f -- | Apply extra @SqlExpr Value@ arguments to a 'PersistField' constructor (<&>) :: SqlExpr (Insertion (a -> b)) -> SqlExpr (Value a) -> SqlExpr (Insertion b) -(EInsert _ f) <&> v = - EInsert Proxy $ \x -> - let (fb, fv) = f x - (gb, gv) = g x - in - (fb <> ", " <> gb, fv ++ gv) - where - g = - case v of - ERaw _ f' -> f' Never +(ERaw _ f) <&> (ERaw _ g) = + ERaw noMeta $ \_ info -> + let (fb, fv) = f Never info + (gb, gv) = g Never info + in (fb <> ", " <> gb, fv ++ gv) -- | @CASE@ statement. For example: -- @@ -2043,8 +2033,8 @@ data SqlExprMeta = SqlExprMeta -- impossible, e.g., for 'val' to disambiguate between these -- uses. sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) - , sqlExprMetaAlias :: Maybe Ident - , sqlExprMetaIsReference :: Bool + , sqlExprMetaAlias :: Maybe Ident -- Alias ident if this is an aliased value/entity + , sqlExprMetaIsReference :: Bool -- Is this SqlExpr a reference to the selected value/entity (supports subqueries) } noMeta :: SqlExprMeta @@ -2061,18 +2051,14 @@ hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields -- -- There are many comments describing the constructors of this -- data type. However, Haddock doesn't like GADTs, so you'll have to read them by hitting \"Source\". -data SqlExpr a where -- Raw expression: states whether parenthesis are needed -- around this expression, and takes information about the SQL -- connection (mainly for escaping names) and returns both an -- string ('TLB.Builder') and a list of values to be -- interpolated by the SQL backend. - ERaw :: SqlExprMeta -> (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr a - - -- Used by 'insertSelect'. - EInsert :: Proxy a -> (IdentInfo -> (TLB.Builder, [PersistValue])) -> SqlExpr (Insertion a) - EInsertFinal :: PersistEntity a => SqlExpr (Insertion a) -> SqlExpr InsertFinal +data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) +-- | Data type to support from hack data PreprocessedFrom a = PreprocessedFrom a FromClause -- | Phantom type used to mark a @INSERT INTO@ query. @@ -2102,9 +2088,8 @@ setAux -> (SqlExpr (Entity val) -> SqlExpr (Value typ)) -> (SqlExpr (Entity val) -> SqlExpr Update) setAux field value = \ent -> ERaw noMeta $ \_ info -> - let (valueToSet, valueVals) = - case value ent of - ERaw _ valueF -> valueF Parens info + let ERaw _ valueF = value ent + (valueToSet, valueVals) = valueF Parens info in (fieldName info field <> " = " <> valueToSet, valueVals) sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) @@ -2214,12 +2199,11 @@ unsafeSqlBinOpComposite op sep a b where isCompositeKey :: SqlExpr (Value x) -> Bool isCompositeKey (ERaw m _) = hasCompositeKeyMeta m - isCompositeKey _ = False listify :: SqlExpr (Value x) -> IdentInfo -> ([TLB.Builder], [PersistValue]) - listify v - | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = flip (,) [] . f - | ERaw _ f <- v = deconstruct . f Parens + listify (ERaw m f) + | Just f <- sqlExprMetaCompositeFields m = flip (,) [] . f + | otherwise = deconstruct . f Parens deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue]) deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals) @@ -2248,9 +2232,7 @@ unsafeSqlEntity ident = ERaw noMeta $ \_ info -> (useIdent info ident, []) valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) -valueToFunctionArg info v = - case v of - ERaw _ f -> f Never info +valueToFunctionArg info (ERaw _ f) = f Never info -- | (Internal) A raw SQL function. Once again, the same warning -- from 'unsafeSqlBinOp' applies to this function as well. @@ -2285,9 +2267,7 @@ unsafeSqlFunctionParens => TLB.Builder -> a -> SqlExpr (Value b) unsafeSqlFunctionParens name arg = ERaw noMeta $ \p info -> - let valueToFunctionArgParens v = - case v of - ERaw _ f -> f p info + let valueToFunctionArgParens (ERaw _ f) = f Never info (argsTLB, argsVals) = uncommas' $ map valueToFunctionArgParens $ toArgList arg in @@ -2296,11 +2276,7 @@ unsafeSqlFunctionParens name arg = -- | (Internal) An explicit SQL type cast using CAST(value as type). -- See 'unsafeSqlBinOp' for warnings. unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b) -unsafeSqlCastAs t v = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . valueToText) - where - valueToText info = - case v of - ERaw _ f -> f Never info +unsafeSqlCastAs t (ERaw _ f) = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . f Never) -- | (Internal) This class allows 'unsafeSqlFunction' to work with different -- numbers of arguments; specifically it allows providing arguments to a sql @@ -2431,13 +2407,13 @@ instance ( UnsafeSqlFunctionArgument a -- 'SqlExpr (Value b)'. You should /not/ use this function -- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) -veryUnsafeCoerceSqlExprValue (ERaw m f) = ERaw m f +veryUnsafeCoerceSqlExprValue = coerce -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) -veryUnsafeCoerceSqlExprValueList (ERaw m f) = ERaw m f +veryUnsafeCoerceSqlExprValueList = coerce ---------------------------------------------------------------------- @@ -2807,7 +2783,7 @@ makeSelect info mode_ distinctClause ret = process mode_ first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $ uncommas' (processExpr <$> exprs) where - processExpr (ERaw m f) = materializeExpr info (ERaw m f :: SqlExpr (Value a)) + processExpr e = materializeExpr info (coerce e :: SqlExpr (Value a)) withCols v = v <> sqlSelectCols info ret plain v = (v, []) @@ -2971,18 +2947,20 @@ class SqlSelect a r | a -> r, r -> a where -- | @INSERT INTO@ hack. -instance SqlSelect (SqlExpr InsertFinal) InsertFinal where - sqlInsertInto info (EInsertFinal (EInsert p _)) = +instance PersistEntity e => SqlSelect (SqlExpr (Insertion e)) (Insertion e) where + sqlInsertInto info e = let fields = uncommas $ map (fromDBName info . fieldDB) $ entityFields $ - entityDef p + entityDef (proxy e) + proxy :: SqlExpr (Insertion a) -> Proxy a + proxy = const Proxy table = - fromDBName info . entityDB . entityDef $ p + fromDBName info . entityDB . entityDef . proxy in - ("INSERT INTO " <> table <> parens fields <> "\n", []) - sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info + ("INSERT INTO " <> table e <> parens fields <> "\n", []) + sqlSelectCols info (ERaw _ f) = f Never info sqlSelectColCount = const 0 sqlSelectProcessRow = const (Right (throw (UnexpectedCaseErr InsertionFinalError))) @@ -3040,7 +3018,7 @@ getEntityVal = const Proxy -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols info (ERaw m f) = sqlSelectCols info (ERaw m f :: SqlExpr (Entity a)) + sqlSelectCols info e = sqlSelectCols info (coerce e :: SqlExpr (Entity a)) sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) @@ -3064,7 +3042,7 @@ materializeExpr info v | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = let bs = f info in (uncommas $ map (parensM Parens) bs, []) - | ERaw m f <- v = f Never info + | ERaw _ f <- v = f Never info -- | You may return tuples (up to 16-tuples) and tuples of tuples @@ -3580,7 +3558,7 @@ insertSelectCount :: (MonadIO m, PersistEntity a) => SqlQuery (SqlExpr (Insertion a)) -> SqlWriteT m Int64 -insertSelectCount = rawEsqueleto INSERT_INTO . fmap EInsertFinal +insertSelectCount = rawEsqueleto INSERT_INTO -- | Renders an expression into 'Text'. Only useful for creating a textual -- representation of the clauses passed to an "On" clause. diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 5f5c2b7..35a2c43 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -298,7 +298,7 @@ insertSelectWithConflictCount unique query conflictQuery = do conn <- R.ask uncurry rawExecuteCount $ combine - (toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query)) + (toRawSql INSERT_INTO (conn, initialIdentState) query) (conflict conn) where proxy :: Proxy val From 2ab733fbeef4712349138a338e57d2688a00903e Mon Sep 17 00:00:00 2001 From: belevy Date: Tue, 19 Jan 2021 14:26:27 -0600 Subject: [PATCH 09/11] Make postgres tests pass --- src/Database/Esqueleto/Experimental/ToAlias.hs | 2 +- .../Esqueleto/Experimental/ToAliasReference.hs | 8 ++++---- src/Database/Esqueleto/Internal/Internal.hs | 12 +++++++++--- test/Common/Test.hs | 1 - 4 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index 39f927a..4187f82 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -23,7 +23,7 @@ instance ToAlias (SqlExpr (Value a)) where ident <- newIdentFor (DBName "v") pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> let (b, v) = f Never info - in (b <> " AS " <> useIdent info ident, []) + in (b <> " AS " <> useIdent info ident, v) instance ToAlias (SqlExpr (Entity a)) where diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index f39a37d..c3f2d11 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -19,22 +19,22 @@ class ToAliasReference a where instance ToAliasReference (SqlExpr (Value a)) where toAliasReference aliasSource (ERaw m _) | Just alias <- sqlExprMetaAlias m = pure $ ERaw m $ \_ info -> - (useIdent info aliasSource <> "." <> useIdent info alias, []) + (useIdent info aliasSource <> "." <> useIdent info alias, []) toAliasReference _ e = pure e instance ToAliasReference (SqlExpr (Entity a)) where toAliasReference aliasSource (ERaw m _) | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> - (useIdent info aliasSource, []) + (useIdent info aliasSource, []) toAliasReference _ e = pure e instance ToAliasReference (SqlExpr (Maybe (Entity a))) where -- FIXME: Code duplication because the compiler doesnt like half final encoding - toAliasReference aliasSource (ERaw m f) + toAliasReference aliasSource (ERaw m _) | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> - (useIdent info aliasSource, []) + (useIdent info aliasSource, []) toAliasReference s e = pure e diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 1f70874..0887c22 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -363,7 +363,9 @@ distinctOnOrderBy exprs act = act where toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn - toDistinctOn = coerce + toDistinctOn (ERaw m f) = ERaw m $ \p info -> + let (b, vals) = f p info + in (TLB.fromLazyText $ head $ TL.splitOn " " $ TLB.toLazyText b, vals) -- | @ORDER BY random()@ clause. -- @@ -918,7 +920,11 @@ in_ :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> Sql ERaw noMeta $ \p info -> let (b1, vals1) = v Parens info (b2, vals2) = list Parens info - in (b1 <> " IN " <> b2, vals1 <> vals2) + in + if b2 == "()" then + ("FALSE", []) + else + (b1 <> " IN " <> b2, vals1 <> vals2) -- | @NOT IN@ operator. notIn :: PersistField typ => SqlExpr (Value typ) -> SqlExpr (ValueList typ) -> SqlExpr (Value Bool) @@ -3042,7 +3048,7 @@ materializeExpr info v | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = let bs = f info in (uncommas $ map (parensM Parens) bs, []) - | ERaw _ f <- v = f Never info + | ERaw _ f <- v = f Parens info -- | You may return tuples (up to 16-tuples) and tuples of tuples diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 4f1fb4b..8eb157b 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -894,7 +894,6 @@ testSelectSubQuery run = describe "select subquery" $ do `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) pure (lords, deeds) - liftIO . print =<< renderQuerySelect q ret <- select q liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds) From 2d09ae1fe8e93c21fa9d2179180931c6a44c2fbc Mon Sep 17 00:00:00 2001 From: belevy Date: Wed, 20 Jan 2021 21:28:26 -0600 Subject: [PATCH 10/11] Change aliased val to be legal value by waiting until expr materialization in select clause before adding AS --- src/Database/Esqueleto/Experimental/ToAlias.hs | 14 +++++--------- src/Database/Esqueleto/Internal/Internal.hs | 10 +++++----- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index 4187f82..4a85143 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -16,15 +16,11 @@ class ToAlias a where toAlias :: a -> SqlQuery a instance ToAlias (SqlExpr (Value a)) where - toAlias (ERaw m f) = - case sqlExprMetaAlias m of - Just _ -> pure $ ERaw m f - Nothing -> do - ident <- newIdentFor (DBName "v") - pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> - let (b, v) = f Never info - in (b <> " AS " <> useIdent info ident, v) - + toAlias e@(ERaw m f) + | Just _ <- sqlExprMetaAlias m, not (sqlExprMetaIsReference m) = pure e + | otherwise = do + ident <- newIdentFor (DBName "v") + pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f instance ToAlias (SqlExpr (Entity a)) where toAlias (ERaw m f) = do diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 0887c22..96c6bce 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -3044,11 +3044,11 @@ instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where -- | Materialize a @SqlExpr (Value a)@. materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) -materializeExpr info v - | ERaw m _ <- v, Just f <- sqlExprMetaCompositeFields m = - let bs = f info - in (uncommas $ map (parensM Parens) bs, []) - | ERaw _ f <- v = f Parens info +materializeExpr info (ERaw m f) + | Just fields <- sqlExprMetaCompositeFields m = (uncommas $ fmap parens $ fields info, []) + | Just alias <- sqlExprMetaAlias m + , not (sqlExprMetaIsReference m) = first (<> " AS " <> useIdent info alias) (f Parens info) + | otherwise = f Parens info -- | You may return tuples (up to 16-tuples) and tuples of tuples From 01407d256bd00223bd78a0fd49fab40730b08b82 Mon Sep 17 00:00:00 2001 From: belevy Date: Wed, 20 Jan 2021 21:35:56 -0600 Subject: [PATCH 11/11] Cleanup ToAliasRefernce; Add isReference meta to value reference even though that info isnt currently used anywhere --- .../Esqueleto/Experimental/ToAliasReference.hs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index c3f2d11..72ac475 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -5,7 +5,7 @@ module Database.Esqueleto.Experimental.ToAliasReference where -import Database.Esqueleto.Experimental.ToAlias +import Data.Coerce import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport @@ -18,7 +18,7 @@ class ToAliasReference a where instance ToAliasReference (SqlExpr (Value a)) where toAliasReference aliasSource (ERaw m _) - | Just alias <- sqlExprMetaAlias m = pure $ ERaw m $ \_ info -> + | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> (useIdent info aliasSource <> "." <> useIdent info alias, []) toAliasReference _ e = pure e @@ -30,12 +30,8 @@ instance ToAliasReference (SqlExpr (Entity a)) where toAliasReference _ e = pure e instance ToAliasReference (SqlExpr (Maybe (Entity a))) where - -- FIXME: Code duplication because the compiler doesnt like half final encoding - toAliasReference aliasSource (ERaw m _) - | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = - pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> - (useIdent info aliasSource, []) - toAliasReference s e = pure e + toAliasReference aliasSource e = + coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a)) instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where