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

Remove entity specific constructors from SqlExpr

Browse Source
This commit is contained in:
belevy 2021-01-18 22:21:56 -06:00
parent 4dc58ec1b8
commit f77134e788
8 changed files with 190 additions and 220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Database/Esqueleto/Experimental/From.hs
View File

@ -52,7 +52,7 @@ instance PersistEntity a => From (Table a) where
runFrom e@Table = do runFrom e@Table = do
let ed = entityDef $ getVal e let ed = entityDef $ getVal e
ident <- newIdentFor (entityDB ed) ident <- newIdentFor (entityDB ed)
let entity = EEntity ident let entity = unsafeSqlEntity ident
pure $ (entity, FromStart ident ed) pure $ (entity, FromStart ident ed)
where where
getVal :: Table ent -> Proxy ent getVal :: Table ent -> Proxy ent

33
src/Database/Esqueleto/Experimental/ToAlias.hs
View File

@ -1,13 +1,12 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Database.Esqueleto.Experimental.ToAlias module Database.Esqueleto.Experimental.ToAlias
where where
import Database.Esqueleto.Internal.Internal hiding (From, import Database.Esqueleto.Internal.Internal hiding (From, from, on)
from, on) import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.PersistentImport
{-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} {-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-}
type ToAliasT a = a type ToAliasT a = a
@ -17,22 +16,26 @@ class ToAlias a where
toAlias :: a -> SqlQuery a toAlias :: a -> SqlQuery a
instance ToAlias (SqlExpr (Value a)) where instance ToAlias (SqlExpr (Value a)) where
toAlias (ERaw m f) toAlias (ERaw m f) =
| Nothing <- sqlExprMetaAlias m = do case sqlExprMetaAlias m of
ident <- newIdentFor (DBName "v") Just _ -> pure $ ERaw m f
pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> Nothing -> do
let (b, v) = f Never info ident <- newIdentFor (DBName "v")
in (b <> " AS " <> useIdent info ident, []) 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 instance ToAlias (SqlExpr (Entity a)) where
toAlias v@(EAliasedEntityReference _ _) = pure v toAlias (ERaw m f) = do
toAlias v@(EAliasedEntity _ _) = pure v
toAlias (EEntity tableIdent) = do
ident <- newIdentFor (DBName "v") ident <- newIdentFor (DBName "v")
pure $ EAliasedEntity ident tableIdent pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f
instance ToAlias (SqlExpr (Maybe (Entity a))) where 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 instance (ToAlias a, ToAlias b) => ToAlias (a,b) where
toAlias (a,b) = (,) <$> toAlias a <*> toAlias b toAlias (a,b) = (,) <$> toAlias a <*> toAlias b

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

@ -1,14 +1,13 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Database.Esqueleto.Experimental.ToAliasReference module Database.Esqueleto.Experimental.ToAliasReference
where where
import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Internal.Internal hiding (From, import Database.Esqueleto.Internal.Internal hiding (From, from, on)
from, on) import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.PersistentImport
{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} {-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-}
type ToAliasReferenceT a = a type ToAliasReferenceT a = a
@ -19,16 +18,24 @@ class ToAliasReference a where
instance ToAliasReference (SqlExpr (Value a)) where instance ToAliasReference (SqlExpr (Value a)) where
toAliasReference aliasSource (ERaw m _) 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, []) (useIdent info aliasSource <> "." <> useIdent info alias, [])
toAliasReference _ e = pure e
instance ToAliasReference (SqlExpr (Entity a)) where instance ToAliasReference (SqlExpr (Entity a)) where
toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident toAliasReference aliasSource (ERaw m _)
toAliasReference _ e@(EEntity _) = toAlias e | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =
toAliasReference s (EAliasedEntityReference _ b) = pure $ EAliasedEntityReference s b pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
(useIdent info aliasSource, [])
toAliasReference _ e = pure e
instance ToAliasReference (SqlExpr (Maybe (Entity a))) where 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 instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where

2
src/Database/Esqueleto/Experimental/ToMaybe.hs
View File

@ -21,7 +21,7 @@ instance ToMaybe (SqlExpr (Maybe a)) where
instance ToMaybe (SqlExpr (Entity a)) where instance ToMaybe (SqlExpr (Entity a)) where
type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a)) type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
toMaybe = EMaybe toMaybe (ERaw f m) = (ERaw f m)
instance ToMaybe (SqlExpr (Value a)) where instance ToMaybe (SqlExpr (Value a)) where
type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a))) type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))

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

@ -88,7 +88,7 @@ fromStart
fromStart = do fromStart = do
let ed = entityDef (Proxy :: Proxy a) let ed = entityDef (Proxy :: Proxy a)
ident <- newIdentFor (entityDB ed) ident <- newIdentFor (entityDB ed)
let ret = EEntity ident let ret = unsafeSqlEntity ident
f' = FromStart ident ed f' = FromStart ident ed
return (EPreprocessedFrom ret f') return (EPreprocessedFrom ret f')
@ -103,7 +103,7 @@ fromStartMaybe = maybelize <$> fromStart
maybelize maybelize
:: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))
-> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (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@. -- | (Internal) Do a @JOIN@.
fromJoin fromJoin
@ -527,9 +527,12 @@ subSelectUnsafe = sub SELECT
=> SqlExpr (Entity val) => SqlExpr (Entity val)
-> EntityField val typ -> EntityField val typ
-> SqlExpr (Value typ) -> SqlExpr (Value typ)
(EAliasedEntityReference source base) ^. field = e ^. field
ERaw noMeta $ \_ info -> | isIdField field = idFieldValue
(useIdent info source <> "." <> useIdent info (aliasedEntityColumnIdent base fieldDef), []) | 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 where
fieldDef = fieldDef =
if isIdField field then if isIdField field then
@ -537,13 +540,6 @@ subSelectUnsafe = sub SELECT
head $ entityKeyFields ed head $ entityKeyFields ed
else else
persistFieldDef field 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 = idFieldValue =
case entityKeyFields ed of case entityKeyFields ed of
idField:[] -> idField:[] ->
@ -558,29 +554,19 @@ e ^. field
ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val)))
dot info fieldDef = dot info fieldDef =
useIdent info sourceIdent <> "." <> fieldIdent sourceIdent info <> "." <> fieldIdent
where where
sourceIdent = sourceIdent =
case e of case e of
EEntity ident -> ident ERaw _ f -> fmap fst $ f Never
EAliasedEntity baseI _ -> baseI
EAliasedEntityReference a b ->
error $ unwords
[ "Used (^.) with an EAliasedEntityReference."
, "Please file this as an Esqueleto bug."
, "EAliasedEntityReference", show a, show b
]
fieldIdent = fieldIdent =
case e of case e of
EEntity _ -> fromDBName info (fieldDB fieldDef) ERaw m f ->
EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef case sqlExprMetaAlias m of
EAliasedEntityReference a b -> Just baseI ->
error $ unwords useIdent info $ aliasedEntityColumnIdent baseI fieldDef
[ "Used (^.) with an EAliasedEntityReference." Nothing ->
, "Please file this as an Esqueleto bug." fromDBName info (fieldDB fieldDef)
, "EAliasedEntityReference", show a, show b
]
-- | Project an SqlExpression that may be null, guarding against null cases. -- | Project an SqlExpression that may be null, guarding against null cases.
withNonNull withNonNull
@ -598,7 +584,7 @@ withNonNull field f = do
=> SqlExpr (Maybe (Entity val)) => SqlExpr (Maybe (Entity val))
-> EntityField val typ -> EntityField val typ
-> SqlExpr (Value (Maybe 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. -- | Lift a constant value from Haskell-land to the query.
val :: PersistField typ => typ -> SqlExpr (Value typ) val :: PersistField typ => typ -> SqlExpr (Value typ)
@ -2012,12 +1998,14 @@ useIdent info (I ident) = fromDBName info $ DBName ident
data SqlExprMeta = SqlExprMeta data SqlExprMeta = SqlExprMeta
{ sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) { sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder])
, sqlExprMetaAlias :: Maybe Ident , sqlExprMetaAlias :: Maybe Ident
, sqlExprMetaIsReference :: Bool
} }
noMeta :: SqlExprMeta noMeta :: SqlExprMeta
noMeta = SqlExprMeta noMeta = SqlExprMeta
{ sqlExprMetaCompositeFields = Nothing { sqlExprMetaCompositeFields = Nothing
, sqlExprMetaAlias = Nothing , sqlExprMetaAlias = Nothing
, sqlExprMetaIsReference = False
} }
hasCompositeKeyMeta :: SqlExprMeta -> Bool hasCompositeKeyMeta :: SqlExprMeta -> Bool
@ -2028,16 +2016,6 @@ hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields
-- There are many comments describing the constructors of this -- 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 type. However, Haddock doesn't like GADTs, so you'll have to read them by hitting \"Source\".
data SqlExpr a where 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 -- Raw expression: states whether parenthesis are needed
-- around this expression, and takes information about the SQL -- around this expression, and takes information about the SQL
-- connection (mainly for escaping names) and returns both an -- 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) unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty)
{-# INLINE unsafeSqlValue #-} {-# 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 :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue])
valueToFunctionArg info v = valueToFunctionArg info v =
case v of case v of
@ -3035,37 +3017,36 @@ unescapedColumnNames ent =
-- | You may return an 'Entity' from a 'select' query. -- | You may return an 'Entity' from a 'select' query.
instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
sqlSelectCols info expr@(EEntity ident) = ret sqlSelectCols info expr@(ERaw m f)
where | Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =
process ed = uncommas $ let process ed = uncommas $
map ((name <>) . TLB.fromText) $ map ((name <>) . aliasName) $
entityColumnNames ed (fst info) unescapedColumnNames ed
-- 'name' is the biggest difference between 'RawSql' and aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName baseIdent info (unDBName columnName)
-- 'SqlSelect'. We automatically create names for tables name = fst (f Never info) <> "."
-- (since it's not the user who's writing the FROM ed = entityDef $ getEntityVal $ return expr
-- clause), while 'rawSql' assumes that it's just the in (process ed, mempty)
-- name of the table (which doesn't allow self-joins, for | Just baseIdent <- sqlExprMetaAlias m, True <- sqlExprMetaIsReference m =
-- example). let process ed = uncommas $
name = useIdent info ident <> "." map ((name <>) . aliasedColumnName baseIdent info . unDBName) $
ret = let ed = entityDef $ getEntityVal $ return expr unescapedColumnNames ed
in (process ed, mempty) name = fst (f Never info) <> "."
sqlSelectCols info expr@(EAliasedEntity aliasIdent tableIdent) = ret ed = entityDef $ getEntityVal $ return expr
where in (process ed, mempty)
process ed = uncommas $ | otherwise =
map ((name <>) . aliasName) $ let process ed = uncommas $
unescapedColumnNames ed map ((name <>) . TLB.fromText) $
aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName aliasIdent info (unDBName columnName) entityColumnNames ed (fst info)
name = useIdent info tableIdent <> "." -- 'name' is the biggest difference between 'RawSql' and
ret = let ed = entityDef $ getEntityVal $ return expr -- 'SqlSelect'. We automatically create names for tables
in (process ed, mempty) -- (since it's not the user who's writing the FROM
sqlSelectCols info expr@(EAliasedEntityReference sourceIdent baseIdent) = ret -- clause), while 'rawSql' assumes that it's just the
where -- name of the table (which doesn't allow self-joins, for
process ed = uncommas $ -- example).
map ((name <>) . aliasedColumnName baseIdent info . unDBName) $ name = fst (f Never info) <> "."
unescapedColumnNames ed ed = entityDef $ getEntityVal $ return expr
name = useIdent info sourceIdent <> "." in (process ed, mempty)
ret = let ed = entityDef $ getEntityVal $ return expr
in (process ed, mempty)
sqlSelectColCount = entityColumnCount . entityDef . getEntityVal sqlSelectColCount = entityColumnCount . entityDef . getEntityVal
sqlSelectProcessRow = parseEntityValues ed sqlSelectProcessRow = parseEntityValues ed
where where
@ -3076,7 +3057,7 @@ getEntityVal = const Proxy
-- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query.
instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where 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 sqlSelectColCount = sqlSelectColCount . fromEMaybe
where where
fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e)

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

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

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

@ -1,8 +1,8 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-- | This module contain PostgreSQL-specific functions. -- | This module contain PostgreSQL-specific functions.
@ -31,23 +31,22 @@ module Database.Esqueleto.PostgreSQL
) where ) where
#if __GLASGOW_HASKELL__ < 804 #if __GLASGOW_HASKELL__ < 804
import Data.Semigroup import Data.Semigroup
#endif #endif
import Control.Arrow (first, (***)) import Control.Arrow (first, (***))
import Control.Exception (throw) import Control.Exception (throw)
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Class (MonadIO(..))
import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.Reader as R
import Data.Int (Int64) import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy (Proxy (..)) import Data.Proxy (Proxy(..))
import qualified Data.Text.Internal.Builder as TLB import qualified Data.Text.Internal.Builder as TLB
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Database.Esqueleto.Internal.Internal hiding (random_) import Database.Esqueleto.Internal.Internal hiding (random_)
import Database.Esqueleto.Internal.PersistentImport hiding (upsert, import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
upsertBy) import Database.Persist.Class (OnlyOneUniqueKey)
import Database.Persist.Class (OnlyOneUniqueKey)
-- | (@random()@) Split out into database specific modules -- | (@random()@) Split out into database specific modules
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.
@ -306,9 +305,9 @@ insertSelectWithConflictCount unique query conflictQuery = do
proxy = Proxy proxy = Proxy
updates = conflictQuery entCurrent entExcluded updates = conflictQuery entCurrent entExcluded
combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2)
entExcluded = EEntity $ I "excluded" entExcluded = unsafeSqlEntity (I "excluded")
tableName = unDBName . entityDB . entityDef tableName = unDBName . entityDB . entityDef
entCurrent = EEntity $ I (tableName proxy) entCurrent = unsafeSqlEntity (I (tableName proxy))
uniqueDef = toUniqueDef unique uniqueDef = toUniqueDef unique
constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef
renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])

143
test/Common/Test.hs
View File

@ -1,25 +1,25 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-} {-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}
@ -62,41 +62,37 @@ module Common.Test
, Key(..) , Key(..)
) where ) where
import Control.Monad (forM_, replicateM, import Control.Monad (forM_, replicateM, replicateM_, void)
replicateM_, void) import Control.Monad.Catch (MonadCatch)
import Control.Monad.Catch (MonadCatch) import Control.Monad.Reader (ask)
import Control.Monad.Reader (ask) import Data.Either
import Data.Either import Data.Time
import Data.Time
#if __GLASGOW_HASKELL__ >= 806 #if __GLASGOW_HASKELL__ >= 806
import Control.Monad.Fail (MonadFail) import Control.Monad.Fail (MonadFail)
#endif #endif
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (MonadLogger (..), import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT)
NoLoggingT, import Control.Monad.Trans.Reader (ReaderT)
runNoLoggingT) import qualified Data.Attoparsec.Text as AP
import Control.Monad.Trans.Reader (ReaderT) import Data.Char (toLower, toUpper)
import qualified Data.Attoparsec.Text as AP import Data.Monoid ((<>))
import Data.Char (toLower, toUpper) import Database.Esqueleto
import Data.Monoid ((<>)) import Database.Esqueleto.Experimental hiding (from, on)
import Database.Esqueleto import qualified Database.Esqueleto.Experimental as Experimental
import Database.Esqueleto.Experimental hiding (from, on) import Database.Persist.TH
import qualified Database.Esqueleto.Experimental as Experimental import Test.Hspec
import Database.Persist.TH import UnliftIO
import Test.Hspec
import UnliftIO
import Data.Conduit (ConduitT, runConduit, import Data.Conduit (ConduitT, runConduit, (.|))
(.|)) import qualified Data.Conduit.List as CL
import qualified Data.Conduit.List as CL import qualified Data.List as L
import qualified Data.List as L import qualified Data.Set as S
import qualified Data.Set as S import qualified Data.Text as Text
import qualified Data.Text as Text import qualified Data.Text.Internal.Lazy as TL
import qualified Data.Text.Internal.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder as TLB
import qualified Database.Esqueleto.Internal.ExprParser as P import qualified Database.Esqueleto.Internal.ExprParser as P
import qualified Database.Esqueleto.Internal.Sql as EI import qualified Database.Esqueleto.Internal.Sql as EI
import qualified UnliftIO.Resource as R import qualified UnliftIO.Resource as R
-- Test schema -- Test schema
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
@ -390,7 +386,6 @@ testSubSelect run = do
describe "subSelectList" $ do describe "subSelectList" $ do
it "is safe on empty databases as well as good databases" $ run $ do it "is safe on empty databases as well as good databases" $ run $ do
liftIO $ putStrLn "hello"
let query = let query =
from $ \n -> do from $ \n -> do
where_ $ n ^. NumbersInt `in_` do where_ $ n ^. NumbersInt `in_` do
@ -399,10 +394,7 @@ testSubSelect run = do
where_ $ n' ^. NumbersInt >=. val 3 where_ $ n' ^. NumbersInt >=. val 3
pure (n' ^. NumbersInt) pure (n' ^. NumbersInt)
pure n pure n
empty <- do empty <- select query
liftIO . print =<< renderQuerySelect query
select query
liftIO $ putStrLn "goodbye"
full <- do full <- do
setup setup
@ -895,12 +887,15 @@ testSelectSubQuery run = describe "select subquery" $ do
l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int]) l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])
let l1WithDeeds = do d <- l1Deeds let l1WithDeeds = do d <- l1Deeds
pure (l1e, Just d) pure (l1e, Just d)
ret <- select $ Experimental.from $ do let q = Experimental.from $ do
(lords :& deeds) <- (lords :& deeds) <-
Experimental.from $ Table @Lord Experimental.from $ Table @Lord
`LeftOuterJoin` Table @Deed `LeftOuterJoin` Table @Deed
`Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
pure (lords, deeds) pure (lords, deeds)
liftIO . print =<< renderQuerySelect q
ret <- select q
liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds) liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)
it "lets you order by alias" $ run $ do it "lets you order by alias" $ run $ do
@ -1847,9 +1842,10 @@ testRenderSql run = do
(c, expr) <- run $ do (c, expr) <- run $ do
conn <- ask conn <- ask
let Right c = P.mkEscapeChar conn 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 $ pure $ (,) c $ EI.renderExpr conn $
EI.EEntity (EI.I "user") ^. PersonId user ^. PersonId ==. blogPost ^. BlogPostAuthorId
==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId
expr expr
`shouldBe` `shouldBe`
Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] 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 <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))
expr `shouldBe` "? = ?" 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 describe "ExprParser" $ do
let parse parser = AP.parseOnly (parser '#') let parse parser = AP.parseOnly (parser '#')
describe "parseEscapedChars" $ do describe "parseEscapedChars" $ do