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

Merge pull request #9 from foxhound-systems/final-expr

Browse Source 
Convert SqlExpr to a final encoding
This commit is contained in:
Ben Levy 2021-02-05 11:39:21 -06:00 committed by GitHub
commit e3ae687309
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 358 additions and 504 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

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

@ -16,20 +16,22 @@ class ToAlias a where
toAlias :: a -> SqlQuery a
instance ToAlias (SqlExpr (Value a)) where
toAlias v@(EAliasedValue _ _) = pure v
toAlias v = do
ident <- newIdentFor (DBName "v")
pure $ EAliasedValue 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 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

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

@ -1,10 +1,11 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
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
@ -16,18 +17,21 @@ 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 _ v@(ECompositeKey _) = toAlias v
toAliasReference s (EValueReference _ b) = pure $ EValueReference s b
toAliasReference aliasSource (ERaw m _)
| Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ 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
toAliasReference aliasSource e =
coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a))
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)))

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

File diff suppressed because it is too large Load Diff

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

@ -37,8 +37,8 @@ module Database.Esqueleto.Internal.Sql
-- * The guts
, unsafeSqlCase
, unsafeSqlBinOp
, unsafeSqlBinOpComposite
, unsafeSqlValue
, unsafeSqlEntity
, unsafeSqlCastAs
, unsafeSqlFunction
, unsafeSqlExtractSubField

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

@ -83,18 +83,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 "
@ -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,22 +292,22 @@ 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
uncurry rawExecuteCount $
combine
(toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))
(toRawSql INSERT_INTO (conn, initialIdentState) query)
(conflict conn)
where
proxy :: Proxy val
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])
@ -355,13 +355,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
)

62
test/Common/Test.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDecls #-}
@ -385,7 +385,7 @@ 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
let query =
from $ \n -> do
where_ $ n ^. NumbersInt `in_` do
@ -394,16 +394,15 @@ testSubSelect run = do
where_ $ n' ^. NumbersInt >=. val 3
pure (n' ^. NumbersInt)
pure n
empty <- select query
empty <- run $ do
select query
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
@ -888,12 +887,14 @@ 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)
ret <- select q
liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)
it "lets you order by alias" $ run $ do
@ -1078,17 +1079,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
@ -1851,9 +1841,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", ""]
@ -1865,23 +1856,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