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

Modify SqlSelect to remove the backwards FunDep. Remove the need for the Value newtype

Browse Source
This commit is contained in:
belevy 2021-02-13 19:47:15 -06:00
parent 096c1acfd6
commit 8aff51b4d8
9 changed files with 371 additions and 363 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Database/Esqueleto.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
-- | The @esqueleto@ EDSL (embedded domain specific language).
-- This module replaces @Database.Persist@, so instead of
@ -74,6 +75,8 @@ module Database.Esqueleto
, else_
, from
, Value(..)
, pattern Value
, unValue
, ValueList(..)
, OrderBy
, DistinctOn

6
src/Database/Esqueleto/Experimental.hs
View File

@ -170,6 +170,7 @@ module Database.Esqueleto.Experimental
, then_
, else_
, Value(..)
, pattern Value
, ValueList(..)
, OrderBy
, DistinctOn
@ -218,7 +219,10 @@ module Database.Esqueleto.Experimental
, module Database.Esqueleto.Internal.PersistentImport
) where
import Database.Esqueleto.Internal.Internal hiding (From, from, on)
import Database.Esqueleto.Internal.Internal hiding
(From,
from,
on)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Experimental.From

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

@ -5,7 +5,8 @@
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." #-}
@ -15,7 +16,7 @@ type ToAliasT a = a
class ToAlias a where
toAlias :: a -> SqlQuery a
instance ToAlias (SqlExpr (Value a)) where
instance {-# OVERLAPPABLE #-} ToAlias (SqlExpr a) where
toAlias e@(ERaw m f)
| Just _ <- sqlExprMetaAlias m, not (sqlExprMetaIsReference m) = pure e
| otherwise = do

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

@ -6,7 +6,8 @@ module Database.Esqueleto.Experimental.ToAliasReference
where
import Data.Coerce
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." #-}
@ -16,7 +17,7 @@ type ToAliasReferenceT a = a
class ToAliasReference a where
toAliasReference :: Ident -> a -> SqlQuery a
instance ToAliasReference (SqlExpr (Value a)) where
instance {-# OVERLAPPABLE #-} ToAliasReference (SqlExpr a) where
toAliasReference aliasSource (ERaw m _)
| Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
(useIdent info aliasSource <> "." <> useIdent info alias, [])

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

@ -4,7 +4,8 @@
module Database.Esqueleto.Experimental.ToMaybe
where
import Database.Esqueleto.Internal.Internal hiding (From(..), from, on)
import Database.Esqueleto.Internal.Internal hiding (From (..),
from, on)
import Database.Esqueleto.Internal.PersistentImport (Entity (..))
type family Nullable a where
@ -15,18 +16,10 @@ class ToMaybe a where
type ToMaybeT a
toMaybe :: a -> ToMaybeT a
instance ToMaybe (SqlExpr (Maybe a)) where
type ToMaybeT (SqlExpr (Maybe a)) = SqlExpr (Maybe a)
toMaybe = id
instance ToMaybe (SqlExpr (Entity a)) where
type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
toMaybe (ERaw f m) = (ERaw f m)
instance ToMaybe (SqlExpr (Value a)) where
type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))
toMaybe = veryUnsafeCoerceSqlExprValue
instance ToMaybe (SqlExpr a) where
type ToMaybeT (SqlExpr a) = SqlExpr (Maybe (Nullable a))
toMaybe = veryUnsafeCoerceSqlExpr
instance (ToMaybe a, ToMaybe b) => ToMaybe (a,b) where
type ToMaybeT (a, b) = (ToMaybeT a, ToMaybeT b)

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

File diff suppressed because it is too large Load Diff

5
src/Database/Esqueleto/Internal/Language.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
@ -17,7 +18,9 @@ module Database.Esqueleto.Internal.Language
{-# DEPRECATED "Use Database.Esqueleto.Internal.Internal instead. This module will be removed in 3.5.0.0 " #-}
( -- * The pretty face
from
, Value(..)
, Value
, pattern Value
, unValue
, ValueList(..)
, SomeValue(..)
, ToSomeValues(..)

35
test/Common/Test.hs
View File

@ -62,7 +62,8 @@ 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,7 +72,9 @@ 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)
@ -83,7 +86,8 @@ 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
@ -497,16 +501,14 @@ testSelectSource run = do
describe "selectSource" $ do
it "works for a simple example" $ run $ do
let query = selectSource $
from $ \person ->
return person
Experimental.from $ Table @Person
p1e <- insert' p1
ret <- runConduit $ query .| CL.consume
liftIO $ ret `shouldBe` [ p1e ]
it "can run a query many times" $ run $ do
let query = selectSource $
from $ \person ->
return person
Experimental.from $ Table @Person
p1e <- insert' p1
ret0 <- runConduit $ query .| CL.consume
ret1 <- runConduit $ query .| CL.consume
@ -535,17 +537,16 @@ testSelectFrom run = do
describe "select/from" $ do
it "works for a simple example" $ run $ do
p1e <- insert' p1
ret <-
select $
from $ \person ->
return person
ret <- select $ Experimental.from $ Table @Person
liftIO $ ret `shouldBe` [ p1e ]
it "works for a simple self-join (one entity)" $ run $ do
p1e <- insert' p1
ret <-
select $
from $ \(person1, person2) ->
select $ do
person1 :& person2 <-
Experimental.from $ Table @Person
`crossJoin` Table @Person
return (person1, person2)
liftIO $ ret `shouldBe` [ (p1e, p1e) ]
@ -553,8 +554,10 @@ testSelectFrom run = do
p1e <- insert' p1
p2e <- insert' p2
ret <-
select $
from $ \(person1, person2) ->
select $ do
person1 :& person2 <-
Experimental.from $ Table @Person
`crossJoin` Table @Person
return (person1, person2)
liftIO $
ret
@ -669,7 +672,7 @@ testSelectFrom run = do
number = 101
Right thePk = keyFromValues [toPersistValue number]
fcPk <- insert fc
[Entity _ ret] <- select $ from return
[Entity _ ret] <- select $ Experimental.from $ Table @Frontcover
liftIO $ do
ret `shouldBe` fc
fcPk `shouldBe` thePk

56
test/PostgreSQL/Test.hs
View File

@ -1,47 +1,49 @@
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# LANGUAGE FlexibleContexts
, LambdaCase
, NamedFieldPuns
, OverloadedStrings
, RankNTypes
, ScopedTypeVariables
, TypeApplications
, TypeFamilies
, PartialTypeSignatures
#-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Main (main) where
import Data.Coerce
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Map (Map)
import Data.Time
import Control.Arrow ((&&&))
import Control.Monad (void, when)
import Control.Monad.Catch (MonadCatch, catch)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT)
import Control.Monad.Logger (runNoLoggingT,
runStderrLoggingT)
import Control.Monad.Trans.Reader (ReaderT, ask)
import qualified Control.Monad.Trans.Resource as R
import Data.Aeson hiding (Value)
import qualified Data.Aeson as A (Value)
import Data.ByteString (ByteString)
import qualified Data.Char as Char
import Data.Coerce
import Data.Foldable
import qualified Data.List as L
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Ord (comparing)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime)
import Data.Time
import Data.Time.Clock (UTCTime, diffUTCTime,
getCurrentTime)
import Database.Esqueleto hiding (random_)
import Database.Esqueleto.Experimental hiding (random_, from, on)
import Database.Esqueleto.Experimental hiding (from, on, random_)
import qualified Database.Esqueleto.Experimental as Experimental
import qualified Database.Esqueleto.Internal.Sql as ES
import Database.Esqueleto.PostgreSQL (random_)
import qualified Database.Esqueleto.PostgreSQL as EP
import Database.Esqueleto.PostgreSQL.JSON hiding ((?.), (-.), (||.))
import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.))
import qualified Database.Esqueleto.PostgreSQL.JSON as JSON
import Database.Persist.Postgresql (withPostgresqlConn)
import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..))
import Database.PostgreSQL.Simple (ExecStatus (..),
SqlError (..))
import System.Environment
import Test.Hspec
import Test.Hspec.QuickCheck
@ -1076,7 +1078,7 @@ testInsertSelectWithConflict =
from $ \p -> return $ OneUnique <# val "test" <&> (p ^. PersonFavNum)
)
(\current excluded -> [OneUniqueValue =. val 4 +. (current ^. OneUniqueValue) +. (excluded ^. OneUniqueValue)])
uniques2 <- select $ from $ \u -> return u
uniques2 <- select $ Experimental.from $ table @OneUnique
liftIO $ n1 `shouldBe` 3
liftIO $ n2 `shouldBe` 3
let test = map (OneUnique "test" . personFavNum) [p1,p2,p3]
@ -1226,7 +1228,7 @@ testLateralQuery = do
select $ do
l :& c <-
Experimental.from $ Table @Lord
`CrossJoin` \lord -> do
`crossJoinLateral` \lord -> do
deed <- Experimental.from $ Table @Deed
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
pure $ countRows @Int
@ -1241,7 +1243,7 @@ testLateralQuery = do
pure $ countRows @Int
res <- select $ do
l :& c <- Experimental.from $ Table @Lord
`InnerJoin` subquery
`innerJoinLateral` subquery
`Experimental.on` (const $ val True)
pure (l, c)
@ -1252,9 +1254,9 @@ testLateralQuery = do
it "supports LEFT JOIN LATERAL" $ do
run $ do
res <- select $ do
l :& c <- Experimental.from $ Table @Lord
`LeftOuterJoin` (\lord -> do
deed <- Experimental.from $ Table @Deed
l :& c <- Experimental.from $ table @Lord
`leftJoinLateral` (\lord -> do
deed <- Experimental.from $ table @Deed
where_ $ lord ^. LordId ==. deed ^. DeedOwnerId
pure $ countRows @Int)
`Experimental.on` (const $ val True)
@ -1295,7 +1297,7 @@ testLateralQuery = do
type JSONValue = Maybe (JSONB A.Value)
createSaneSQL :: (PersistField a) => SqlExpr (Value a) -> T.Text -> [PersistValue] -> IO ()
createSaneSQL :: (ES.SqlSelect (SqlExpr a) a, PersistField a) => SqlExpr a -> T.Text -> [PersistValue] -> IO ()
createSaneSQL act q vals = run $ do
(query, args) <- showQuery ES.SELECT $ fromValue act
liftIO $ query `shouldBe` q