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

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

@ -36,17 +36,16 @@ import Data.Semigroup
import Control.Arrow (first, (***))
import Control.Exception (throw)
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 Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty (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 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])

45
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
@ -71,10 +70,8 @@ import Data.Time
#if __GLASGOW_HASKELL__ >= 806
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (MonadLogger (..),
NoLoggingT,
runNoLoggingT)
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)
@ -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