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

Cleanup the rest of the Values, fix the example code and update to use Esqueleto.Experimental

Browse Source
This commit is contained in:
belevy 2021-02-13 20:35:21 -06:00
parent 6b12edbd8c
commit 1f52363407
15 changed files with 190 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
examples/Main.hs
View File

@ -10,6 +10,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
@ -19,15 +20,14 @@ module Main
) where ) where
import Blog import Blog
import Control.Monad (void) import Control.Monad (forM_, void)
import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Logger (MonadLogger) import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader (MonadReader(..), runReaderT) import Control.Monad.Reader (MonadReader(..), runReaderT)
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Database.Esqueleto import Database.Esqueleto.Experimental
import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn)
import Database.Persist.TH import Database.Persist.TH
( AtLeastOneUniqueKey(..) ( AtLeastOneUniqueKey(..)
@ -62,9 +62,9 @@ putPersons :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
putPersons = do putPersons = do
-- | Select all values from the `person` table -- | Select all values from the `person` table
people <- select $ people <- select $ do
from $ \person -> do person <- from $ table @Person
return person return person
-- | entityVal extracts the Person value, which we then extract -- | entityVal extracts the Person value, which we then extract
-- | the person name from the record and print it -- | the person name from the record and print it
@ -75,8 +75,8 @@ getJohns :: (MonadIO m, MonadLogger m)
=> SqlReadT m [Entity Person] => SqlReadT m [Entity Person]
getJohns = getJohns =
-- | Select all persons where their name is equal to "John" -- | Select all persons where their name is equal to "John"
select $ select $ do
from $ \p -> do p <- from $ table @Person
where_ (p ^. PersonName ==. val "John") where_ (p ^. PersonName ==. val "John")
return p return p
@ -85,8 +85,8 @@ getAdults :: (MonadIO m, MonadLogger m)
=> SqlReadT m [Entity Person] => SqlReadT m [Entity Person]
getAdults = getAdults =
-- | Select any Person where their age is >= 18 and NOT NULL -- | Select any Person where their age is >= 18 and NOT NULL
select $ select $ do
from $ \p -> do p <- from $ table @Person
where_ (p ^. PersonAge >=. just (val 18)) where_ (p ^. PersonAge >=. just (val 18))
return p return p
@ -95,8 +95,10 @@ getBlogPostsByAuthors :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity BlogPost, Entity Person)] => SqlReadT m [(Entity BlogPost, Entity Person)]
getBlogPostsByAuthors = getBlogPostsByAuthors =
-- | Select all persons and their blogposts, ordering by title -- | Select all persons and their blogposts, ordering by title
select $ select $ do
from $ \(b, p) -> do p :& b <-
from $ table @Person
`crossJoin` table @BlogPost
where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)
orderBy [asc (b ^. BlogPostTitle)] orderBy [asc (b ^. BlogPostTitle)]
return (b, p) return (b, p)
@ -108,9 +110,11 @@ getAuthorMaybePosts =
-- | Select all persons doing a left outer join on blogposts -- | Select all persons doing a left outer join on blogposts
-- | Since a person may not have any blogposts the BlogPost Entity is wrapped -- | Since a person may not have any blogposts the BlogPost Entity is wrapped
-- | in a Maybe -- | in a Maybe
select $ select $ do
from $ \(p `LeftOuterJoin` mb) -> do (p :& mb) <-
on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) from $ table @Person
`leftJoin` table @BlogPost
`on` (\(p :& mb) -> (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId))
orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)]
return (p, mb) return (p, mb)
@ -122,10 +126,13 @@ followers =
-- | Note carefully that the order of the ON clauses is reversed! -- | Note carefully that the order of the ON clauses is reversed!
-- | You're required to write your ons in reverse order because that helps composability -- | You're required to write your ons in reverse order because that helps composability
-- | (see the documentation of on for more details). -- | (see the documentation of on for more details).
select $ select $ do
from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do (p1 :& f :& p2) <-
on (p2 ^. PersonId ==. f ^. FollowFollowed) from $ table @Person
on (p1 ^. PersonId ==. f ^. FollowFollower) `innerJoin` table @Follow
`on` (\(p1 :& f) -> p1 ^. PersonId ==. f ^. FollowFollower)
`innerJoin` table @Person
`on` (\(_ :& f :& p2) -> p2 ^. PersonId ==. f ^. FollowFollowed)
return (p1, f, p2) return (p1, f, p2)
@ -146,8 +153,8 @@ deleteYoungsters = do
-- | In this case where `ON DELETE CASCADE` is not generated by migration -- | In this case where `ON DELETE CASCADE` is not generated by migration
-- | we select all the entities we want to delete and then for each one -- | we select all the entities we want to delete and then for each one
-- | one we extract the key and use Persistent's `deleteCascade` -- | one we extract the key and use Persistent's `deleteCascade`
youngsters <- select $ youngsters <- select $ do
from $ \p -> do p <- from $ table @Person
where_ (p ^. PersonAge <. just (val 14)) where_ (p ^. PersonAge <. just (val 14))
pure p pure p
forM_ youngsters (deleteCascade . entityKey) forM_ youngsters (deleteCascade . entityKey)
@ -157,7 +164,8 @@ insertBlogPosts :: (MonadIO m, MonadLogger m)
=> SqlWriteT m () => SqlWriteT m ()
insertBlogPosts = insertBlogPosts =
-- | Insert a new blogpost for every person -- | Insert a new blogpost for every person
insertSelect $ from $ \p -> insertSelect $ do
p <- from $ table @Person
return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)

22
src/Database/Esqueleto.hs
View File

@ -1,8 +1,8 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
-- | The @esqueleto@ EDSL (embedded domain specific language). -- | The @esqueleto@ EDSL (embedded domain specific language).
-- This module replaces @Database.Persist@, so instead of -- This module replaces @Database.Persist@, so instead of
-- importing that module you should just import this one: -- importing that module you should just import this one:
@ -126,13 +126,13 @@ module Database.Esqueleto
, module Database.Esqueleto.Internal.PersistentImport , module Database.Esqueleto.Internal.PersistentImport
) where ) where
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Reader (ReaderT)
import Data.Int (Int64) import Data.Int (Int64)
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Database.Esqueleto.Internal.Language import Database.Esqueleto.Internal.Language
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Internal.Sql import Database.Esqueleto.Internal.Sql
import qualified Database.Persist import qualified Database.Persist

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

@ -219,19 +219,16 @@ module Database.Esqueleto.Experimental
, module Database.Esqueleto.Internal.PersistentImport , module Database.Esqueleto.Internal.PersistentImport
) where ) where
import Database.Esqueleto.Internal.Internal hiding import Database.Esqueleto.Internal.Internal hiding (From, from, on)
(From, import Database.Esqueleto.Internal.PersistentImport
from,
on)
import Database.Esqueleto.Internal.PersistentImport
import Database.Esqueleto.Experimental.From import Database.Esqueleto.Experimental.From
import Database.Esqueleto.Experimental.From.CommonTableExpression import Database.Esqueleto.Experimental.From.CommonTableExpression
import Database.Esqueleto.Experimental.From.Join import Database.Esqueleto.Experimental.From.Join
import Database.Esqueleto.Experimental.From.SqlSetOperation import Database.Esqueleto.Experimental.From.SqlSetOperation
import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Experimental.ToMaybe import Database.Esqueleto.Experimental.ToMaybe
-- $setup -- $setup
-- --

85
src/Database/Esqueleto/Experimental/From/Join.hs
View File

@ -1,37 +1,32 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Database.Esqueleto.Experimental.From.Join module Database.Esqueleto.Experimental.From.Join
where where
import Data.Bifunctor (first) import Data.Bifunctor (first)
import Data.Kind (Constraint) import Data.Kind (Constraint)
import Data.Proxy import Data.Proxy
import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Text.Lazy.Builder as TLB
import Database.Esqueleto.Experimental.From import Database.Esqueleto.Experimental.From
import Database.Esqueleto.Experimental.From.SqlSetOperation import Database.Esqueleto.Experimental.From.SqlSetOperation
import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAlias
import Database.Esqueleto.Experimental.ToAliasReference import Database.Esqueleto.Experimental.ToAliasReference
import Database.Esqueleto.Experimental.ToMaybe import Database.Esqueleto.Experimental.ToMaybe
import Database.Esqueleto.Internal.Internal hiding import Database.Esqueleto.Internal.Internal hiding
(From (..), (From(..), from, fromJoin, on)
from, import Database.Esqueleto.Internal.PersistentImport
fromJoin, (Entity(..), EntityField, PersistEntity, PersistField)
on) import GHC.TypeLits
import Database.Esqueleto.Internal.PersistentImport (Entity (..),
EntityField,
PersistEntity,
PersistField)
import GHC.TypeLits
-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions -- | A left-precedence pair. Pronounced \"and\". Used to represent expressions
-- that have been joined together. -- that have been joined together.
@ -65,7 +60,7 @@ instance ValidOnClause (a -> SqlQuery b)
-- \`on\` (\\(p :& bP) -> -- \`on\` (\\(p :& bP) ->
-- p ^. PersonId ==. bP ^. BlogPostAuthorId) -- p ^. PersonId ==. bP ^. BlogPostAuthorId)
-- @ -- @
on :: ValidOnClause a => a -> (b -> SqlExpr (Value Bool)) -> (a, b -> SqlExpr (Value Bool)) on :: ValidOnClause a => a -> (b -> SqlExpr Bool) -> (a, b -> SqlExpr Bool)
on = (,) on = (,)
infix 9 `on` infix 9 `on`
@ -73,7 +68,7 @@ type family ErrorOnLateral a :: Constraint where
ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.") ErrorOnLateral (a -> SqlQuery b) = TypeError ('Text "LATERAL can only be used for INNER, LEFT, and CROSS join kinds.")
ErrorOnLateral _ = () ErrorOnLateral _ = ()
fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr (Value Bool)) -> RawFn fromJoin :: TLB.Builder -> RawFn -> RawFn -> Maybe (SqlExpr Bool) -> RawFn
fromJoin joinKind lhs rhs monClause = fromJoin joinKind lhs rhs monClause =
\paren info -> \paren info ->
first (parensM paren) $ first (parensM paren) $
@ -86,14 +81,14 @@ fromJoin joinKind lhs rhs monClause =
makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info) makeOnClause info (ERaw _ f) = first (" ON " <>) (f Never info)
type family HasOnClause actual expected :: Constraint where type family HasOnClause actual expected :: Constraint where
HasOnClause (a, b -> SqlExpr (Value Bool)) c = () -- Let the compiler handle the type mismatch HasOnClause (a, b -> SqlExpr Bool) c = () -- Let the compiler handle the type mismatch
HasOnClause a expected = HasOnClause a expected =
TypeError ( 'Text "Missing ON clause for join with" TypeError ( 'Text "Missing ON clause for join with"
':$$: 'ShowType a ':$$: 'ShowType a
':$$: 'Text "" ':$$: 'Text ""
':$$: 'Text "Expected: " ':$$: 'Text "Expected: "
':$$: 'ShowType a ':$$: 'ShowType a
':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr (Value Bool)) ':$$: 'Text "`on` " ':<>: 'ShowType (expected -> SqlExpr Bool)
':$$: 'Text "" ':$$: 'Text ""
) )
@ -114,7 +109,7 @@ type family HasOnClause actual expected :: Constraint where
innerJoin :: ( ToFrom a a' innerJoin :: ( ToFrom a a'
, ToFrom b b' , ToFrom b b'
, HasOnClause rhs (a' :& b') , HasOnClause rhs (a' :& b')
, rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool)) , rhs ~ (b, (a' :& b') -> SqlExpr Bool)
) => a -> rhs -> From (a' :& b') ) => a -> rhs -> From (a' :& b')
innerJoin lhs (rhs, on') = From $ do innerJoin lhs (rhs, on') = From $ do
(leftVal, leftFrom) <- unFrom (toFrom lhs) (leftVal, leftFrom) <- unFrom (toFrom lhs)
@ -138,7 +133,7 @@ innerJoinLateral :: ( ToFrom a a'
, SqlSelect b r , SqlSelect b r
, ToAlias b , ToAlias b
, ToAliasReference b , ToAliasReference b
, rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr (Value Bool)) , rhs ~ (a' -> SqlQuery b, (a' :& b) -> SqlExpr Bool)
) )
=> a -> rhs -> From (a' :& b) => a -> rhs -> From (a' :& b)
innerJoinLateral lhs (rhsFn, on') = From $ do innerJoinLateral lhs (rhsFn, on') = From $ do
@ -210,7 +205,7 @@ leftJoin :: ( ToFrom a a'
, ToFrom b b' , ToFrom b b'
, ToMaybe b' , ToMaybe b'
, HasOnClause rhs (a' :& ToMaybeT b') , HasOnClause rhs (a' :& ToMaybeT b')
, rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr (Value Bool)) , rhs ~ (b, (a' :& ToMaybeT b') -> SqlExpr Bool)
) => a -> rhs -> From (a' :& ToMaybeT b') ) => a -> rhs -> From (a' :& ToMaybeT b')
leftJoin lhs (rhs, on') = From $ do leftJoin lhs (rhs, on') = From $ do
(leftVal, leftFrom) <- unFrom (toFrom lhs) (leftVal, leftFrom) <- unFrom (toFrom lhs)
@ -236,7 +231,7 @@ leftJoinLateral :: ( ToFrom a a'
, ToAlias b , ToAlias b
, ToAliasReference b , ToAliasReference b
, ToMaybe b , ToMaybe b
, rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr (Value Bool)) , rhs ~ (a' -> SqlQuery b, (a' :& ToMaybeT b) -> SqlExpr Bool)
) )
=> a -> rhs -> From (a' :& ToMaybeT b) => a -> rhs -> From (a' :& ToMaybeT b)
leftJoinLateral lhs (rhsFn, on') = From $ do leftJoinLateral lhs (rhsFn, on') = From $ do
@ -266,7 +261,7 @@ rightJoin :: ( ToFrom a a'
, ToFrom b b' , ToFrom b b'
, ToMaybe a' , ToMaybe a'
, HasOnClause rhs (ToMaybeT a' :& b') , HasOnClause rhs (ToMaybeT a' :& b')
, rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr (Value Bool)) , rhs ~ (b, (ToMaybeT a' :& b') -> SqlExpr Bool)
) => a -> rhs -> From (ToMaybeT a' :& b') ) => a -> rhs -> From (ToMaybeT a' :& b')
rightJoin lhs (rhs, on') = From $ do rightJoin lhs (rhs, on') = From $ do
(leftVal, leftFrom) <- unFrom (toFrom lhs) (leftVal, leftFrom) <- unFrom (toFrom lhs)
@ -295,7 +290,7 @@ fullOuterJoin :: ( ToFrom a a'
, ToMaybe a' , ToMaybe a'
, ToMaybe b' , ToMaybe b'
, HasOnClause rhs (ToMaybeT a' :& ToMaybeT b') , HasOnClause rhs (ToMaybeT a' :& ToMaybeT b')
, rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr (Value Bool)) , rhs ~ (b, (ToMaybeT a' :& ToMaybeT b') -> SqlExpr Bool)
) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b') ) => a -> rhs -> From (ToMaybeT a' :& ToMaybeT b')
fullOuterJoin lhs (rhs, on') = From $ do fullOuterJoin lhs (rhs, on') = From $ do
(leftVal, leftFrom) <- unFrom (toFrom lhs) (leftVal, leftFrom) <- unFrom (toFrom lhs)
@ -329,7 +324,7 @@ class DoInnerJoin lateral lhs rhs res | lateral rhs lhs -> res where
instance ( ToFrom a a' instance ( ToFrom a a'
, ToFrom b b' , ToFrom b b'
, HasOnClause rhs (a' :& b') , HasOnClause rhs (a' :& b')
, rhs ~ (b, (a' :& b') -> SqlExpr (Value Bool)) , rhs ~ (b, (a' :& b') -> SqlExpr Bool)
) => DoInnerJoin NotLateral a rhs (a' :& b') where ) => DoInnerJoin NotLateral a rhs (a' :& b') where
doInnerJoin _ = innerJoin doInnerJoin _ = innerJoin
@ -338,7 +333,7 @@ instance ( ToFrom a a'
, ToAlias b , ToAlias b
, ToAliasReference b , ToAliasReference b
, d ~ (a' :& b) , d ~ (a' :& b)
) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where ) => DoInnerJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr Bool) d where
doInnerJoin _ = innerJoinLateral doInnerJoin _ = innerJoinLateral
instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs ) instance ( DoInnerJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
@ -353,7 +348,7 @@ instance ( ToFrom a a'
, ToMaybe b' , ToMaybe b'
, ToMaybeT b' ~ mb , ToMaybeT b' ~ mb
, HasOnClause rhs (a' :& mb) , HasOnClause rhs (a' :& mb)
, rhs ~ (b, (a' :& mb) -> SqlExpr (Value Bool)) , rhs ~ (b, (a' :& mb) -> SqlExpr Bool)
) => DoLeftJoin NotLateral a rhs (a' :& mb) where ) => DoLeftJoin NotLateral a rhs (a' :& mb) where
doLeftJoin _ = leftJoin doLeftJoin _ = leftJoin
@ -363,7 +358,7 @@ instance ( ToFrom a a'
, SqlSelect b r , SqlSelect b r
, ToAlias b , ToAlias b
, ToAliasReference b , ToAliasReference b
) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr (Value Bool)) d where ) => DoLeftJoin Lateral a (a' -> SqlQuery b, d -> SqlExpr Bool) d where
doLeftJoin _ = leftJoinLateral doLeftJoin _ = leftJoinLateral
instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs ) instance ( DoLeftJoin lateral lhs rhs r, lateral ~ IsLateral rhs )
@ -389,7 +384,7 @@ instance ( ToFrom a a'
, ToMaybeT a' ~ ma , ToMaybeT a' ~ ma
, HasOnClause rhs (ma :& b') , HasOnClause rhs (ma :& b')
, ErrorOnLateral b , ErrorOnLateral b
, rhs ~ (b, (ma :& b') -> SqlExpr (Value Bool)) , rhs ~ (b, (ma :& b') -> SqlExpr Bool)
) => ToFrom (RightOuterJoin a rhs) (ma :& b') where ) => ToFrom (RightOuterJoin a rhs) (ma :& b') where
toFrom (RightOuterJoin a b) = rightJoin a b toFrom (RightOuterJoin a b) = rightJoin a b
@ -401,7 +396,7 @@ instance ( ToFrom a a'
, ToMaybeT b' ~ mb , ToMaybeT b' ~ mb
, HasOnClause rhs (ma :& mb) , HasOnClause rhs (ma :& mb)
, ErrorOnLateral b , ErrorOnLateral b
, rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool)) , rhs ~ (b, (ma :& mb) -> SqlExpr Bool)
) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where
toFrom (FullOuterJoin a b) = fullOuterJoin a b toFrom (FullOuterJoin a b) = fullOuterJoin a b

7
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

9
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 Data.Coerce import Data.Coerce
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

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

@ -1,12 +1,11 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Database.Esqueleto.Experimental.ToMaybe module Database.Esqueleto.Experimental.ToMaybe
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 (Entity(..))
import Database.Esqueleto.Internal.PersistentImport (Entity (..))
type family Nullable a where type family Nullable a where
Nullable (Maybe a) = a Nullable (Maybe a) = a

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

@ -132,7 +132,7 @@ fromFinish (PreprocessedFrom ret f') = Q $ do
return ret return ret
-- | @WHERE@ clause: restrict the query's result. -- | @WHERE@ clause: restrict the query's result.
where_ :: SqlExpr (Bool) -> SqlQuery () where_ :: SqlExpr Bool -> SqlQuery ()
where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr } where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
-- | An @ON@ clause, useful to describe how two tables are related. Cross joins -- | An @ON@ clause, useful to describe how two tables are related. Cross joins
@ -191,7 +191,7 @@ where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
-- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId) -- 'on' (baz '^.' BazId '==.' bar '^.' BarBazId)
-- ... -- ...
-- @ -- @
on :: SqlExpr (Bool) -> SqlQuery () on :: SqlExpr Bool -> SqlQuery ()
on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] } on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }
-- | @GROUP BY@ clause. You can enclose multiple columns -- | @GROUP BY@ clause. You can enclose multiple columns
@ -377,7 +377,7 @@ rand = ERaw noMeta $ \_ _ -> ("RANDOM()", [])
-- | @HAVING@. -- | @HAVING@.
-- --
-- @since 1.2.2 -- @since 1.2.2
having :: SqlExpr (Bool) -> SqlQuery () having :: SqlExpr Bool -> SqlQuery ()
having expr = Q $ W.tell mempty { sdHavingClause = Where expr } having expr = Q $ W.tell mempty { sdHavingClause = Where expr }
-- | Add a locking clause to the query. Please read -- | Add a locking clause to the query. Please read
@ -617,7 +617,7 @@ val v = ERaw noMeta $ \_ _ -> ("?", [toPersistValue v])
-- > - error: {lhs: v ==. val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing} -- > - error: {lhs: v ==. val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}
-- > - error: {lhs: v !=. nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing} -- > - error: {lhs: v !=. nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing}
-- > - error: {lhs: v !=. val Nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing} -- > - error: {lhs: v !=. val Nothing, rhs: not_ (Database.Esqueleto.isNothing v), name: Use Esqueleto's not isNothing}
isNothing :: PersistField typ => SqlExpr ((Maybe typ)) -> SqlExpr (Bool) isNothing :: PersistField typ => SqlExpr ((Maybe typ)) -> SqlExpr Bool
isNothing v = isNothing v =
case v of case v of
ERaw m f -> ERaw m f ->
@ -673,7 +673,7 @@ count = countHelper "" ""
countDistinct :: Num a => SqlExpr typ -> SqlExpr a countDistinct :: Num a => SqlExpr typ -> SqlExpr a
countDistinct = countHelper "(DISTINCT " ")" countDistinct = countHelper "(DISTINCT " ")"
not_ :: SqlExpr (Bool) -> SqlExpr (Bool) not_ :: SqlExpr Bool -> SqlExpr Bool
not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info
where where
x p info = x p info =
@ -685,27 +685,28 @@ not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info
let (b, vals) = f Never info let (b, vals) = f Never info
in (parensM p b, vals) in (parensM p b, vals)
(==.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr (Bool)
(==.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr Bool
(==.) = unsafeSqlBinOpComposite " = " " AND " (==.) = unsafeSqlBinOpComposite " = " " AND "
(>=.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr (Bool) (>=.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr Bool
(>=.) = unsafeSqlBinOp " >= " (>=.) = unsafeSqlBinOp " >= "
(>.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr (Bool) (>.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr Bool
(>.) = unsafeSqlBinOp " > " (>.) = unsafeSqlBinOp " > "
(<=.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr (Bool) (<=.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr Bool
(<=.) = unsafeSqlBinOp " <= " (<=.) = unsafeSqlBinOp " <= "
(<.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr (Bool) (<.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr Bool
(<.) = unsafeSqlBinOp " < " (<.) = unsafeSqlBinOp " < "
(!=.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr (Bool) (!=.) :: PersistField typ => SqlExpr typ -> SqlExpr typ -> SqlExpr Bool
(!=.) = unsafeSqlBinOpComposite " != " " OR " (!=.) = unsafeSqlBinOpComposite " != " " OR "
(&&.) :: SqlExpr (Bool) -> SqlExpr (Bool) -> SqlExpr (Bool) (&&.) :: SqlExpr Bool -> SqlExpr Bool -> SqlExpr Bool
(&&.) = unsafeSqlBinOp " AND " (&&.) = unsafeSqlBinOp " AND "
(||.) :: SqlExpr (Bool) -> SqlExpr (Bool) -> SqlExpr (Bool) (||.) :: SqlExpr Bool -> SqlExpr Bool -> SqlExpr Bool
(||.) = unsafeSqlBinOp " OR " (||.) = unsafeSqlBinOp " OR "
(+.) :: PersistField a => SqlExpr a -> SqlExpr a -> SqlExpr a (+.) :: PersistField a => SqlExpr a -> SqlExpr a -> SqlExpr a
@ -723,7 +724,7 @@ not_ v = ERaw noMeta $ \p info -> first ("NOT " <>) $ x p info
-- | @BETWEEN@. -- | @BETWEEN@.
-- --
-- @since: 3.1.0 -- @since: 3.1.0
between :: PersistField a => SqlExpr a -> (SqlExpr a, SqlExpr a) -> SqlExpr (Bool) between :: PersistField a => SqlExpr a -> (SqlExpr a, SqlExpr a) -> SqlExpr Bool
a `between` (b, c) = a >=. b &&. a <=. c a `between` (b, c) = a >=. b &&. a <=. c
random_ :: (PersistField a, Num a) => SqlExpr a random_ :: (PersistField a, Num a) => SqlExpr a
@ -831,7 +832,7 @@ right_ :: (SqlString s, Num a) => (SqlExpr s, SqlExpr a) -> SqlExpr s
right_ = unsafeSqlFunction "RIGHT" right_ = unsafeSqlFunction "RIGHT"
-- | @LIKE@ operator. -- | @LIKE@ operator.
like :: SqlString s => SqlExpr s -> SqlExpr s -> SqlExpr (Bool) like :: SqlString s => SqlExpr s -> SqlExpr s -> SqlExpr Bool
like = unsafeSqlBinOp " LIKE " like = unsafeSqlBinOp " LIKE "
-- | @ILIKE@ operator (case-insensitive @LIKE@). -- | @ILIKE@ operator (case-insensitive @LIKE@).
@ -839,7 +840,7 @@ like = unsafeSqlBinOp " LIKE "
-- Supported by PostgreSQL only. -- Supported by PostgreSQL only.
-- --
-- @since 2.2.3 -- @since 2.2.3
ilike :: SqlString s => SqlExpr s -> SqlExpr s -> SqlExpr (Bool) ilike :: SqlString s => SqlExpr s -> SqlExpr s -> SqlExpr Bool
ilike = unsafeSqlBinOp " ILIKE " ilike = unsafeSqlBinOp " ILIKE "
-- | The string @'%'@. May be useful while using 'like' and -- | The string @'%'@. May be useful while using 'like' and
@ -915,7 +916,7 @@ justList (ERaw m f) = ERaw m f
-- @ -- @
-- --
-- Where @personIds@ is of type @[Key Person]@. -- Where @personIds@ is of type @[Key Person]@.
in_ :: PersistField typ => SqlExpr typ -> SqlExpr (ValueList typ) -> SqlExpr (Bool) in_ :: PersistField typ => SqlExpr typ -> SqlExpr (ValueList typ) -> SqlExpr Bool
(ERaw _ v) `in_` (ERaw _ list) = (ERaw _ v) `in_` (ERaw _ list) =
ERaw noMeta $ \p info -> ERaw noMeta $ \p info ->
let (b1, vals1) = v Parens info let (b1, vals1) = v Parens info
@ -927,7 +928,7 @@ in_ :: PersistField typ => SqlExpr typ -> SqlExpr (ValueList typ) -> SqlExpr (Bo
(b1 <> " IN " <> b2, vals1 <> vals2) (b1 <> " IN " <> b2, vals1 <> vals2)
-- | @NOT IN@ operator. -- | @NOT IN@ operator.
notIn :: PersistField typ => SqlExpr typ -> SqlExpr (ValueList typ) -> SqlExpr (Bool) notIn :: PersistField typ => SqlExpr typ -> SqlExpr (ValueList typ) -> SqlExpr Bool
(ERaw _ v) `notIn` (ERaw _ list) = (ERaw _ v) `notIn` (ERaw _ list) =
ERaw noMeta $ \p info -> ERaw noMeta $ \p info ->
let (b1, vals1) = v Parens info let (b1, vals1) = v Parens info
@ -944,14 +945,14 @@ notIn :: PersistField typ => SqlExpr typ -> SqlExpr (ValueList typ) -> SqlExpr (
-- 'where_' (post '^.' BlogPostAuthorId '==.' person '^.' PersonId) -- 'where_' (post '^.' BlogPostAuthorId '==.' person '^.' PersonId)
-- return person -- return person
-- @ -- @
exists :: SqlQuery () -> SqlExpr (Bool) exists :: SqlQuery () -> SqlExpr Bool
exists q = ERaw noMeta $ \p info -> exists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q let ERaw _ f = existsHelper q
(b, vals) = f Never info (b, vals) = f Never info
in ( parensM p $ "EXISTS " <> b, vals) in ( parensM p $ "EXISTS " <> b, vals)
-- | @NOT EXISTS@ operator. -- | @NOT EXISTS@ operator.
notExists :: SqlQuery () -> SqlExpr (Bool) notExists :: SqlQuery () -> SqlExpr Bool
notExists q = ERaw noMeta $ \p info -> notExists q = ERaw noMeta $ \p info ->
let ERaw _ f = existsHelper q let ERaw _ f = existsHelper q
(b, vals) = f Never info (b, vals) = f Never info
@ -1033,7 +1034,7 @@ field /=. expr = setAux field (\ent -> ent ^. field /. expr)
-- reproduce this via 'nothing'. -- reproduce this via 'nothing'.
-- --
-- @since 2.1.2 -- @since 2.1.2
case_ :: PersistField a => [(SqlExpr (Bool), SqlExpr a)] -> SqlExpr a -> SqlExpr a case_ :: PersistField a => [(SqlExpr Bool, SqlExpr a)] -> SqlExpr a -> SqlExpr a
case_ = unsafeSqlCase case_ = unsafeSqlCase
-- | Convert an entity's key into another entity's. -- | Convert an entity's key into another entity's.
@ -1092,7 +1093,7 @@ infixl 2 `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuter
-- | Syntax sugar for 'case_'. -- | Syntax sugar for 'case_'.
-- --
-- @since 2.1.2 -- @since 2.1.2
when_ :: expr (Bool) -> () -> expr a -> (expr (Bool), expr a) when_ :: expr Bool -> () -> expr a -> (expr Bool, expr a)
when_ cond _ expr = (cond, expr) when_ cond _ expr = (cond, expr)
-- | Syntax sugar for 'case_'. -- | Syntax sugar for 'case_'.
@ -1733,8 +1734,8 @@ instance Monoid DistinctClause where
-- | A part of a @FROM@ clause. -- | A part of a @FROM@ clause.
data FromClause data FromClause
= FromStart Ident EntityDef = FromStart Ident EntityDef
| FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Bool))) | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr Bool))
| OnClause (SqlExpr (Bool)) | OnClause (SqlExpr Bool)
| FromRaw (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) | FromRaw (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
data CommonTableExpressionKind data CommonTableExpressionKind
@ -1795,7 +1796,7 @@ newtype SetClause = SetClause (SqlExpr Update)
collectOnClauses collectOnClauses
:: SqlBackend :: SqlBackend
-> [FromClause] -> [FromClause]
-> Either (SqlExpr (Bool)) [FromClause] -> Either (SqlExpr Bool) [FromClause]
collectOnClauses sqlBackend = go Set.empty [] collectOnClauses sqlBackend = go Set.empty []
where where
go is [] (f@(FromStart i _) : fs) = go is [] (f@(FromStart i _) : fs) =
@ -1811,8 +1812,8 @@ collectOnClauses sqlBackend = go Set.empty []
findMatching findMatching
:: Set Ident :: Set Ident
-> [FromClause] -> [FromClause]
-> SqlExpr (Bool) -> SqlExpr Bool
-> Either (SqlExpr (Bool)) (Set Ident, [FromClause]) -> Either (SqlExpr Bool) (Set Ident, [FromClause])
findMatching idents fromClauses expr = findMatching idents fromClauses expr =
case fromClauses of case fromClauses of
f : acc -> f : acc ->
@ -1841,7 +1842,7 @@ collectOnClauses sqlBackend = go Set.empty []
tryMatch tryMatch
:: Set Ident :: Set Ident
-> SqlExpr (Bool) -> SqlExpr Bool
-> FromClause -> FromClause
-> Maybe (Set Ident, FromClause) -> Maybe (Set Ident, FromClause)
tryMatch idents expr fromClause = tryMatch idents expr fromClause =
@ -1906,7 +1907,7 @@ collectOnClauses sqlBackend = go Set.empty []
$ renderedExpr $ renderedExpr
-- | A complete @WHERE@ clause. -- | A complete @WHERE@ clause.
data WhereClause = Where (SqlExpr (Bool)) data WhereClause = Where (SqlExpr Bool)
| NoWhere | NoWhere
instance Semigroup WhereClause where instance Semigroup WhereClause where
@ -2058,6 +2059,9 @@ hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields
-- interpolated by the SQL backend. -- interpolated by the SQL backend.
data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]))
instance Num a => Num (SqlExpr a) where
-- | Data type to support from hack -- | Data type to support from hack
data PreprocessedFrom a = PreprocessedFrom a FromClause data PreprocessedFrom a = PreprocessedFrom a FromClause
@ -2098,16 +2102,16 @@ sub mode query = ERaw noMeta $ \_ info -> first parens $ toRawSql mode info quer
fromDBName :: IdentInfo -> DBName -> TLB.Builder fromDBName :: IdentInfo -> DBName -> TLB.Builder
fromDBName (conn, _) = TLB.fromText . connEscapeName conn fromDBName (conn, _) = TLB.fromText . connEscapeName conn
existsHelper :: SqlQuery () -> SqlExpr (Bool) existsHelper :: SqlQuery () -> SqlExpr Bool
existsHelper = sub SELECT . (>> return true) existsHelper = sub SELECT . (>> return true)
where where
true :: SqlExpr (Bool) true :: SqlExpr Bool
true = val True true = val True
-- | (Internal) Create a case statement. -- | (Internal) Create a case statement.
-- --
-- Since: 2.1.1 -- Since: 2.1.1
unsafeSqlCase :: PersistField a => [(SqlExpr (Bool), SqlExpr a)] -> SqlExpr a -> SqlExpr a unsafeSqlCase :: PersistField a => [(SqlExpr Bool, SqlExpr a)] -> SqlExpr a -> SqlExpr a
unsafeSqlCase when v = ERaw noMeta buildCase unsafeSqlCase when v = ERaw noMeta buildCase
where where
buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) buildCase :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
@ -2116,11 +2120,11 @@ unsafeSqlCase when v = ERaw noMeta buildCase
(whenText, whenVals) = mapWhen when Parens info (whenText, whenVals) = mapWhen when Parens info
in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals) in ( "CASE" <> whenText <> " ELSE " <> elseText <> " END", whenVals <> elseVals)
mapWhen :: [(SqlExpr (Bool), SqlExpr a)] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) mapWhen :: [(SqlExpr Bool, SqlExpr a)] -> NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])
mapWhen [] _ _ = throw (UnexpectedCaseErr UnsafeSqlCaseError) mapWhen [] _ _ = throw (UnexpectedCaseErr UnsafeSqlCaseError)
mapWhen when' p info = foldl (foldHelp p info) (mempty, mempty) when' mapWhen when' p info = foldl (foldHelp p info) (mempty, mempty) when'
foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Bool), SqlExpr a) -> (TLB.Builder, [PersistValue]) foldHelp :: NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr Bool, SqlExpr a) -> (TLB.Builder, [PersistValue])
foldHelp p info (b0, vals0) (v1, v2) = foldHelp p info (b0, vals0) (v1, v2) =
let (b1, vals1) = valueToSql v1 p info let (b1, vals1) = valueToSql v1 p info
(b2, vals2) = valueToSql v2 p info (b2, vals2) = valueToSql v2 p info
@ -2135,7 +2139,7 @@ unsafeSqlCase when v = ERaw noMeta buildCase
-- signature. For example: -- signature. For example:
-- --
-- @ -- @
-- (==.) :: SqlExpr a -> SqlExpr a -> SqlExpr (Bool) -- (==.) :: SqlExpr a -> SqlExpr a -> SqlExpr Bool
-- (==.) = unsafeSqlBinOp " = " -- (==.) = unsafeSqlBinOp " = "
-- @ -- @
-- --
@ -2176,7 +2180,7 @@ unsafeSqlBinOp op a b = unsafeSqlBinOp op (construct a) (construct b)
-- Usage example: -- Usage example:
-- --
-- @ -- @
-- (==.) :: SqlExpr a -> SqlExpr a -> SqlExpr (Bool) -- (==.) :: SqlExpr a -> SqlExpr a -> SqlExpr Bool
-- (==.) = unsafeSqlBinOpComposite " = " " AND " -- (==.) = unsafeSqlBinOpComposite " = " " AND "
-- @ -- @
-- --
@ -2832,7 +2836,7 @@ makeFrom info mode fs = ret
makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info) makeOnClause (ERaw _ f) = first (" ON " <>) (f Never info)
mkExc :: SqlExpr (Bool) -> OnClauseWithoutMatchingJoinException mkExc :: SqlExpr Bool -> OnClauseWithoutMatchingJoinException
mkExc (ERaw _ f) = mkExc (ERaw _ f) =
OnClauseWithoutMatchingJoinException $ OnClauseWithoutMatchingJoinException $
TL.unpack $ TLB.toLazyText $ fst (f Never info) TL.unpack $ TLB.toLazyText $ fst (f Never info)
@ -3545,7 +3549,7 @@ insertSelectCount = rawEsqueleto INSERT_INTO
-- representation of the clauses passed to an "On" clause. -- representation of the clauses passed to an "On" clause.
-- --
-- @since 3.2.0 -- @since 3.2.0
renderExpr :: SqlBackend -> SqlExpr (Bool) -> T.Text renderExpr :: SqlBackend -> SqlExpr Bool -> T.Text
renderExpr sqlBackend e = case e of renderExpr sqlBackend e = case e of
ERaw _ mkBuilderValues -> ERaw _ mkBuilderValues ->
let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState) let (builder, _) = mkBuilderValues Never (sqlBackend, initialIdentState)

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

@ -1,13 +1,13 @@
{-# 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 MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# 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
-- may change without a major version bump. Please use only -- may change without a major version bump. Please use only
@ -139,5 +139,5 @@ module Database.Esqueleto.Internal.Language
, subSelectUnsafe , subSelectUnsafe
) where ) where
import Database.Esqueleto.Internal.Internal import Database.Esqueleto.Internal.Internal
import Database.Esqueleto.Internal.PersistentImport import Database.Esqueleto.Internal.PersistentImport

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

@ -151,6 +151,7 @@ import Database.Persist.Sql hiding
, delete , delete
, deleteCascadeWhere , deleteCascadeWhere
, deleteWhereCount , deleteWhereCount
, exists
, getPersistMap , getPersistMap
, limitOffsetOrder , limitOffsetOrder
, listToJSON , listToJSON
@ -174,5 +175,4 @@ import Database.Persist.Sql hiding
, (>.) , (>.)
, (>=.) , (>=.)
, (||.) , (||.)
, exists
) )

2
src/Database/Esqueleto/MySQL.hs
View File

@ -14,5 +14,5 @@ import Database.Esqueleto.Internal.PersistentImport
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.
-- --
-- /Since: 2.6.0/ -- /Since: 2.6.0/
random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ :: (PersistField a, Num a) => SqlExpr a
random_ = unsafeSqlValue "RAND()" random_ = unsafeSqlValue "RAND()"

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

@ -52,18 +52,18 @@ import Database.Persist.Class (OnlyOneUniqueKey)
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.
-- --
-- @since 2.6.0 -- @since 2.6.0
random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ :: (PersistField a, Num a) => SqlExpr a
random_ = unsafeSqlValue "RANDOM()" random_ = unsafeSqlValue "RANDOM()"
-- | Empty array literal. (@val []@) does unfortunately not work -- | Empty array literal. (@val []@) does unfortunately not work
emptyArray :: SqlExpr (Value [a]) emptyArray :: SqlExpr [a]
emptyArray = unsafeSqlValue "'{}'" emptyArray = unsafeSqlValue "'{}'"
-- | Coalesce an array with an empty default value -- | Coalesce an array with an empty default value
maybeArray :: maybeArray ::
(PersistField a, PersistField [a]) (PersistField a, PersistField [a])
=> SqlExpr (Value (Maybe [a])) => SqlExpr (Maybe [a])
-> SqlExpr (Value [a]) -> SqlExpr [a]
maybeArray x = coalesceDefault [x] (emptyArray) maybeArray x = coalesceDefault [x] (emptyArray)
-- | Aggregate mode -- | Aggregate mode
@ -82,7 +82,7 @@ unsafeSqlAggregateFunction
-> AggMode -> AggMode
-> a -> a
-> [OrderByClause] -> [OrderByClause]
-> SqlExpr (Value b) -> SqlExpr b
unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info -> unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info ->
let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
-- Don't add a space if we don't have order by clauses -- Don't add a space if we don't have order by clauses
@ -106,14 +106,14 @@ unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info
--- into an array. --- into an array.
arrayAggWith arrayAggWith
:: AggMode :: AggMode
-> SqlExpr (Value a) -> SqlExpr a
-> [OrderByClause] -> [OrderByClause]
-> SqlExpr (Value (Maybe [a])) -> SqlExpr (Maybe [a])
arrayAggWith = unsafeSqlAggregateFunction "array_agg" arrayAggWith = unsafeSqlAggregateFunction "array_agg"
--- | (@array_agg@) Concatenate input values, including @NULL@s, --- | (@array_agg@) Concatenate input values, including @NULL@s,
--- into an array. --- into an array.
arrayAgg :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe [a])) arrayAgg :: (PersistField a) => SqlExpr a -> SqlExpr (Maybe [a])
arrayAgg x = arrayAggWith AggModeAll x [] arrayAgg x = arrayAggWith AggModeAll x []
-- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into -- | (@array_agg@) Concatenate distinct input values, including @NULL@s, into
@ -122,19 +122,19 @@ arrayAgg x = arrayAggWith AggModeAll x []
-- @since 2.5.3 -- @since 2.5.3
arrayAggDistinct arrayAggDistinct
:: (PersistField a, PersistField [a]) :: (PersistField a, PersistField [a])
=> SqlExpr (Value a) => SqlExpr a
-> SqlExpr (Value (Maybe [a])) -> SqlExpr (Maybe [a])
arrayAggDistinct x = arrayAggWith AggModeDistinct x [] arrayAggDistinct x = arrayAggWith AggModeDistinct x []
-- | (@array_remove@) Remove all elements equal to the given value from the -- | (@array_remove@) Remove all elements equal to the given value from the
-- array. -- array.
-- --
-- @since 2.5.3 -- @since 2.5.3
arrayRemove :: SqlExpr (Value [a]) -> SqlExpr (Value a) -> SqlExpr (Value [a]) arrayRemove :: SqlExpr [a] -> SqlExpr a -> SqlExpr [a]
arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem') arrayRemove arr elem' = unsafeSqlFunction "array_remove" (arr, elem')
-- | Remove @NULL@ values from an array -- | Remove @NULL@ values from an array
arrayRemoveNull :: SqlExpr (Value [Maybe a]) -> SqlExpr (Value [a]) arrayRemoveNull :: SqlExpr [Maybe a] -> SqlExpr [a]
-- This can't be a call to arrayRemove because it changes the value type -- This can't be a call to arrayRemove because it changes the value type
arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL") arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")
@ -144,10 +144,10 @@ arrayRemoveNull x = unsafeSqlFunction "array_remove" (x, unsafeSqlValue "NULL")
stringAggWith :: stringAggWith ::
SqlString s SqlString s
=> AggMode -- ^ Aggregate mode (ALL or DISTINCT) => AggMode -- ^ Aggregate mode (ALL or DISTINCT)
-> SqlExpr (Value s) -- ^ Input values. -> SqlExpr s -- ^ Input values.
-> SqlExpr (Value s) -- ^ Delimiter. -> SqlExpr s -- ^ Delimiter.
-> [OrderByClause] -- ^ ORDER BY clauses -> [OrderByClause] -- ^ ORDER BY clauses
-> SqlExpr (Value (Maybe s)) -- ^ Concatenation. -> SqlExpr (Maybe s) -- ^ Concatenation.
stringAggWith mode expr delim os = stringAggWith mode expr delim os =
unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os unsafeSqlAggregateFunction "string_agg" mode (expr, delim) os
@ -157,19 +157,19 @@ stringAggWith mode expr delim os =
-- @since 2.2.8 -- @since 2.2.8
stringAgg :: stringAgg ::
SqlString s SqlString s
=> SqlExpr (Value s) -- ^ Input values. => SqlExpr s -- ^ Input values.
-> SqlExpr (Value s) -- ^ Delimiter. -> SqlExpr s -- ^ Delimiter.
-> SqlExpr (Value (Maybe s)) -- ^ Concatenation. -> SqlExpr (Maybe s) -- ^ Concatenation.
stringAgg expr delim = stringAggWith AggModeAll expr delim [] stringAgg expr delim = stringAggWith AggModeAll expr delim []
-- | (@chr@) Translate the given integer to a character. (Note the result will -- | (@chr@) Translate the given integer to a character. (Note the result will
-- depend on the character set of your database.) -- depend on the character set of your database.)
-- --
-- @since 2.2.11 -- @since 2.2.11
chr :: SqlString s => SqlExpr (Value Int) -> SqlExpr (Value s) chr :: SqlString s => SqlExpr Int -> SqlExpr s
chr = unsafeSqlFunction "chr" chr = unsafeSqlFunction "chr"
now_ :: SqlExpr (Value UTCTime) now_ :: SqlExpr UTCTime
now_ = unsafeSqlFunction "NOW" () now_ = unsafeSqlFunction "NOW" ()
upsert upsert
@ -350,11 +350,11 @@ insertSelectWithConflictCount unique query conflictQuery = do
-- --
-- @since 3.3.3.3 -- @since 3.3.3.3
filterWhere filterWhere
:: SqlExpr (Value a) :: SqlExpr a
-- ^ Aggregate function -- ^ Aggregate function
-> SqlExpr (Value Bool) -> SqlExpr Bool
-- ^ Filter clause -- ^ Filter clause
-> SqlExpr (Value a) -> SqlExpr a
filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info -> filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->
let (aggBuilder, aggValues) = case aggExpr of let (aggBuilder, aggValues) = case aggExpr of
ERaw _ aggF -> aggF Never info ERaw _ aggF -> aggF Never info

16
src/Database/Esqueleto/PostgreSQL/JSON.hs
View File

@ -189,7 +189,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Value (Maybe Text)) (->>.) :: JSONBExpr a -> JSONAccessor -> SqlExpr (Maybe Text)
(->>.) value (JSONKey txt) = unsafeSqlBinOp " ->> " value $ val txt (->>.) value (JSONKey txt) = unsafeSqlBinOp " ->> " value $ val txt
(->>.) value (JSONIndex i) = unsafeSqlBinOp " ->> " value $ val i (->>.) value (JSONIndex i) = unsafeSqlBinOp " ->> " value $ val i
@ -253,7 +253,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Value (Maybe Text)) (#>>.) :: JSONBExpr a -> [Text] -> SqlExpr (Maybe Text)
(#>>.) value = unsafeSqlBinOp " #>> " value . mkTextArray (#>>.) value = unsafeSqlBinOp " #>> " value . mkTextArray
-- | /Requires PostgreSQL version >= 9.4/ -- | /Requires PostgreSQL version >= 9.4/
@ -275,7 +275,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool) (@>.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr Bool
(@>.) = unsafeSqlBinOp " @> " (@>.) = unsafeSqlBinOp " @> "
-- | /Requires PostgreSQL version >= 9.4/ -- | /Requires PostgreSQL version >= 9.4/
@ -297,7 +297,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr (Value Bool) (<@.) :: JSONBExpr a -> JSONBExpr b -> SqlExpr Bool
(<@.) = unsafeSqlBinOp " <@ " (<@.) = unsafeSqlBinOp " <@ "
-- | /Requires PostgreSQL version >= 9.4/ -- | /Requires PostgreSQL version >= 9.4/
@ -320,7 +320,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(?.) :: JSONBExpr a -> Text -> SqlExpr (Value Bool) (?.) :: JSONBExpr a -> Text -> SqlExpr Bool
(?.) value = unsafeSqlBinOp " ?? " value . val (?.) value = unsafeSqlBinOp " ?? " value . val
-- | /Requires PostgreSQL version >= 9.4/ -- | /Requires PostgreSQL version >= 9.4/
@ -343,7 +343,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(?|.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool) (?|.) :: JSONBExpr a -> [Text] -> SqlExpr Bool
(?|.) value = unsafeSqlBinOp " ??| " value . mkTextArray (?|.) value = unsafeSqlBinOp " ??| " value . mkTextArray
-- | /Requires PostgreSQL version >= 9.4/ -- | /Requires PostgreSQL version >= 9.4/
@ -366,7 +366,7 @@ infixl 6 ||., -., --., #-.
-- @ -- @
-- --
-- @since 3.1.0 -- @since 3.1.0
(?&.) :: JSONBExpr a -> [Text] -> SqlExpr (Value Bool) (?&.) :: JSONBExpr a -> [Text] -> SqlExpr Bool
(?&.) value = unsafeSqlBinOp " ??& " value . mkTextArray (?&.) value = unsafeSqlBinOp " ??& " value . mkTextArray
-- | /Requires PostgreSQL version >= 9.5/ -- | /Requires PostgreSQL version >= 9.5/
@ -579,5 +579,5 @@ infixl 6 ||., -., --., #-.
(#-.) :: JSONBExpr a -> [Text] -> JSONBExpr b (#-.) :: JSONBExpr a -> [Text] -> JSONBExpr b
(#-.) value = unsafeSqlBinOp " #- " value . mkTextArray (#-.) value = unsafeSqlBinOp " #- " value . mkTextArray
mkTextArray :: [Text] -> SqlExpr (Value PersistValue) mkTextArray :: [Text] -> SqlExpr PersistValue
mkTextArray = val . PersistArray . fmap toPersistValue mkTextArray = val . PersistArray . fmap toPersistValue

6
src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs
View File

@ -2,13 +2,13 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# language DerivingStrategies #-}
module Database.Esqueleto.PostgreSQL.JSON.Instances where module Database.Esqueleto.PostgreSQL.JSON.Instances where
import Data.Aeson (FromJSON(..), ToJSON(..), encode, eitherDecodeStrict) import Data.Aeson (FromJSON(..), ToJSON(..), eitherDecodeStrict, encode)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BSL (toStrict) import qualified Data.ByteString.Lazy as BSL (toStrict)
import Data.String (IsString(..)) import Data.String (IsString(..))
@ -42,7 +42,7 @@ newtype JSONB a = JSONB { unJSONB :: a }
-- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'. -- | 'SqlExpr' of a NULL-able 'JSONB' value. Hence the 'Maybe'.
-- --
-- Note: NULL here is a PostgreSQL NULL, not a JSON 'null' -- Note: NULL here is a PostgreSQL NULL, not a JSON 'null'
type JSONBExpr a = SqlExpr (Value (Maybe (JSONB a))) type JSONBExpr a = SqlExpr (Maybe (JSONB a))
-- | Convenience function to lift a regular value into -- | Convenience function to lift a regular value into
-- a 'JSONB' expression. -- a 'JSONB' expression.

2
src/Database/Esqueleto/SQLite.hs
View File

@ -14,5 +14,5 @@ import Database.Esqueleto.Internal.PersistentImport
-- because MySQL uses `rand()`. -- because MySQL uses `rand()`.
-- --
-- /Since: 2.6.0/ -- /Since: 2.6.0/
random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ :: (PersistField a, Num a) => SqlExpr a
random_ = unsafeSqlValue "RANDOM()" random_ = unsafeSqlValue "RANDOM()"