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
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

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

@ -5,8 +5,7 @@
module Database.Esqueleto.Experimental.ToAlias
where
import Database.Esqueleto.Internal.Internal hiding (From,
from, on)
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." #-}
@ -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
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

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

@ -6,8 +6,7 @@ module Database.Esqueleto.Experimental.ToAliasReference
where
import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Internal.Internal hiding (From,
from, on)
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." #-}
@ -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

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
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)))

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

@ -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 =
e ^. field
| isIdField field = idFieldValue
| ERaw m f <- e, Just alias <- sqlExprMetaAlias m =
ERaw noMeta $ \_ info ->
(useIdent info source <> "." <> useIdent info (aliasedEntityColumnIdent base fieldDef), [])
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,9 +3017,24 @@ 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 $
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
@ -3046,26 +3043,10 @@ instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where
-- 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
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)

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

@ -38,6 +38,7 @@ module Database.Esqueleto.Internal.Sql
, unsafeSqlCase
, unsafeSqlBinOp
, unsafeSqlValue
, unsafeSqlEntity
, unsafeSqlCastAs
, unsafeSqlFunction
, unsafeSqlExtractSubField

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

@ -45,8 +45,7 @@ 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.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy)
import Database.Persist.Class (OnlyOneUniqueKey)
-- | (@random()@) Split out into database specific modules
@ -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])

43
test/Common/Test.hs
View File

@ -62,8 +62,7 @@ module Common.Test
, Key(..)
) where
import Control.Monad (forM_, replicateM,
replicateM_, void)
import Control.Monad (forM_, replicateM, replicateM_, void)
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Reader (ask)
import Data.Either
@ -72,9 +71,7 @@ import Data.Time
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger (MonadLogger (..),
NoLoggingT,
runNoLoggingT)
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)
@ -86,8 +83,7 @@ import Database.Persist.TH
import Test.Hspec
import UnliftIO
import Data.Conduit (ConduitT, runConduit,
(.|))
import Data.Conduit (ConduitT, runConduit, (.|))
import qualified Data.Conduit.List as CL
import qualified Data.List as L
import qualified Data.Set as S
@ -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
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