esqueleto (empty) → 0.1
raw patch · 7 files changed
+2137/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, conduit, esqueleto, fast-logger, hspec, monad-control, monad-logger, persistent, persistent-sqlite, persistent-template, resourcet, template-haskell, text, transformers, transformers-base, unordered-containers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- esqueleto.cabal +92/−0
- src/Database/Esqueleto.hs +297/−0
- src/Database/Esqueleto/Internal/Language.hs +427/−0
- src/Database/Esqueleto/Internal/Sql.hs +811/−0
- test/Test.hs +478/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Felipe Lessa++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Felipe Lessa nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ esqueleto.cabal view
@@ -0,0 +1,92 @@+name: esqueleto+version: 0.1+synopsis: Bare bones, type-safe EDSL for SQL queries on persistent backends.+homepage: https://github.com/meteficha/esqueleto+license: BSD3+license-file: LICENSE+author: Felipe Lessa+maintainer: felipe.lessa@gmail.com+copyright: (c) 2012 Felipe Almeida Lessa+category: Database+build-type: Simple+cabal-version: >=1.8+description:+ /This is a preview release./+ .+ @persistent@ is a library for type-safe data serialization. It+ has many kinds of backends, such as SQL backends+ (@persistent-mysql@, @persistent-postgresql@,+ @persistent-sqlite@) and NoSQL backends (@persistent-mongoDB@).+ .+ While @persistent@ is a nice library for storing and retrieving+ records, currently it has a poor interface for SQL backends+ compared to SQL itself. For example, it's extremely hard to do+ a type-safe @JOIN@ on a many-to-one relation, and simply+ impossible to do any other kinds of @JOIN@s (including for the+ very common many-to-many relations). Users have the option of+ writing raw SQL, but that's error prone and not type-checked.+ .+ @esqueleto@ is a bare bones, type-safe EDSL for SQL queries+ that works with unmodified @persistent@ SQL backends. Its+ language closely resembles SQL, so (a) you don't have to learn+ new concepts, just new syntax, and (b) it's fairly easy to+ predict the generated SQL and optimize it for your backend.+ Most kinds of errors committed when writing SQL are caught as+ compile-time errors---although it is possible to write+ type-checked @esqueleto@ queries that fail at runtime.+ .+ Currently only @SELECT@s are supported. Not all SQL features+ are available, but most of them can be easily added (especially+ functions), so please open an issue or send a pull request if+ you need anything that is not covered by @esqueleto@ on+ <https://github.com/meteficha/esqueleto/>.+ .+ The name of this library means \"skeleton\" in Portuguese and+ contains all three SQL letters in the correct order =).++source-repository head+ type: git+ location: git://github.com/meteficha/esqueleto.git++library+ exposed-modules:+ Database.Esqueleto+ Database.Esqueleto.Internal.Language+ Database.Esqueleto.Internal.Sql+ build-depends:+ base == 4.5.*+ , text == 0.11.*+ , persistent >= 1.0.1 && < 1.1+ , transformers == 0.3.*+ , unordered-containers >= 0.2++ , monad-logger+ , conduit+ , resourcet+ hs-source-dirs: src/+ ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ hs-source-dirs: test+ main-is: Test.hs+ build-depends:+ -- Library dependencies used on the tests. No need to+ -- specify versions since they'll use the same as above.+ base, persistent, transformers, conduit, text++ -- Test-only dependencies+ , HUnit+ , QuickCheck+ , hspec == 1.3.*+ , persistent-sqlite == 1.0.*+ , persistent-template == 1.0.*+ , monad-control+ , monad-logger+ , fast-logger == 0.2.*+ , transformers-base+ , template-haskell++ -- This library+ , esqueleto
+ src/Database/Esqueleto.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}+-- | The @esqueleto@ EDSL (embedded domain specific language).+-- This module replaces @Database.Persist@, so instead of+-- importing that module you should just import this one:+--+-- @+-- import Database.Esqueleto+-- import qualified Database.Persist.Query as OldQuery+-- @+module Database.Esqueleto+ ( -- * Setup+ -- $setup++ -- * Introduction+ -- $introduction++ -- * Getting started+ -- $gettingstarted++ -- * @esqueleto@'s Language+ Esqueleto( where_, on, orderBy, asc, desc+ , sub_select, sub_selectDistinct, (^.), (?.)+ , val, isNothing, just, nothing, countRows, not_+ , (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.)+ , (+.), (-.), (/.), (*.)+ , set, (=.), (+=.), (-=.), (*=.), (/=.) )+ , from+ , OrderBy+ -- ** Joins+ , InnerJoin(..)+ , CrossJoin(..)+ , LeftOuterJoin(..)+ , RightOuterJoin(..)+ , FullOuterJoin(..)+ , OnClauseWithoutMatchingJoinException(..)++ -- * SQL backend+ , SqlQuery+ , SqlExpr+ , select+ , selectDistinct+ , selectSource+ , selectDistinctSource+ , delete+ , update++ -- * Re-exports+ -- $reexports+ , deleteKey+ , module Database.Persist.GenericSql+ , module Database.Persist.Store+ ) where++import Database.Esqueleto.Internal.Language+import Database.Esqueleto.Internal.Sql+import Database.Persist.Store hiding (delete)+import Database.Persist.GenericSql+import qualified Database.Persist.Store++-- $setup+--+-- If you're already using @persistent@, then you're ready to use+-- @esqueleto@, no further setup is needed. If you're just+-- starting a new project and would like to use @esqueleto@, take+-- a look at @persistent@'s book first+-- (<http://www.yesodweb.com/book/persistent>) to learn how to+-- define your schema.++----------------------------------------------------------------------++-- $introduction+--+-- The main goals of @esqueleto@ are to:+--+-- * Be easily translatable to SQL. When you take a look at a+-- @esqueleto@ query, you should be able to know exactly how+-- the SQL query will end up. (As opposed to being a+-- relational algebra EDSL such as HaskellDB, which is+-- non-trivial to translate into SQL.)+--+-- * Support the mostly used SQL features. We'd like you to be+-- able to use @esqueleto@ for all of your queries, no+-- exceptions. Send a pull request or open an issue on our+-- project page (<https://github.com/meteficha/esqueleto>) if+-- there's anything missing that you'd like to see.+--+-- * Be as type-safe as possible. There are ways of shooting+-- yourself in the foot while using @esqueleto@ because it's+-- extremely hard to provide 100% type-safety into a SQL-like+-- EDSL---there's a tension between supporting features with a+-- nice syntax and rejecting bad code. However, we strive to+-- provide as many type checks as possible. If you get bitten+-- by some invalid code that type-checks, please open an issue+-- on our project page so we can take a look.++----------------------------------------------------------------------++-- $gettingstarted+--+-- We like clean, easy-to-read EDSLs. However, in order to+-- achieve this goal we've used a lot of type hackery, leading to+-- some hard-to-read type signatures. On this section, we'll try+-- to build some intuition about the syntax.+--+-- For the following examples, we'll use this example schema:+--+-- @+-- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"] [persist|+-- Person+-- name String+-- age Int Maybe+-- deriving Eq Show+-- BlogPost+-- title String+-- authorId PersonId+-- deriving Eq Show+-- Follow+-- follower PersonId+-- followed PersonId+-- deriving Eq Show+-- |]+-- @+--+-- Most of @esqueleto@ was created with @SELECT@ statements in+-- mind, not only because they're the most common but also+-- because they're the most complex kind of statement. The most+-- simple kind of @SELECT@ would be:+--+-- @+-- SELECT *+-- FROM Person+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- do people <- 'select' $+-- 'from' $ \\person -> do+-- return person+-- liftIO $ mapM_ (putStrLn . personName . entityVal) people+-- @+--+-- The expression above has type @SqlPersist m ()@, while+-- @people@ has type @[Entity Person]@. The query above will be+-- translated into exactly the same query we wrote manually, but+-- instead of @SELECT *@ it will list all entity fields (using+-- @*@ is not robust). Note that @esqueleto@ knows that we want+-- an @Entity Person@ just because of the @personName@ that we're+-- printing later.+--+-- However, most of the time we need to filter our queries using+-- @WHERE@. For example:+--+-- @+-- SELECT *+-- FROM Person+-- WHERE Person.name = \"John\"+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- select $+-- from $ \\p -> do+-- 'where_' (p '^.' PersonName '==.' 'val' \"John\")+-- return p+-- @+--+-- Although @esqueleto@'s code is a bit more noisy, it's has+-- almost the same structure (save from the @return@). The+-- @('^.')@ operator is used to project a field from an entity.+-- The field name is the same one generated by @persistent@'s+-- Template Haskell functions. We use 'val' to lift a constant+-- Haskell value into the SQL query.+--+-- Another example would be:+--+-- @+-- SELECT *+-- FROM Person+-- WHERE Person.age >= 18+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- select $+-- from $ \\p -> do+-- where_ (p ^. PersonAge '>=.' 'just' (val 18))+-- return p+-- @+--+-- Since @age@ is an optional @Person@ field, we use 'just' lift+-- @val 18 :: SqlExpr (Single Int)@ into @just (val 18) ::+-- SqlExpr (Single (Just Int))@.+--+-- Implicit joins are represented by tuples. For example, to get+-- the list of all blog posts and their authors, we could write:+--+-- @+-- SELECT BlogPost.*, Person.*+-- FROM BlogPost, Person+-- WHERE BlogPost.authorId = Person.id+-- ORDER BY BlogPost.title ASC+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- select $+-- from $ \\(b, p) -> do+-- where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)+-- 'orderBy' ['asc' (b ^. BlogPostTitle)]+-- return (b, p)+-- @+--+-- However, we may want your results to include people who don't+-- have any blog posts as well using a @LEFT OUTER JOIN@:+--+-- @+-- SELECT Person.*, BlogPost.*+-- FROM Person LEFT OUTER JOIN BlogPost+-- ON Person.id = BlogPost.authorId+-- ORDER BY Person.name ASC, BlogPost.title ASC+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- select $+-- from $ \\(p ``LeftOuterJoin`` mb) -> do+-- 'on' (just (p ^. PersonId) ==. mb '?.' BlogPostAuthorId)+-- orderBy [asc (p ^. PersonName), asc (mb '?.' BlogPostTitle)]+-- return (p, mb)+-- @+--+-- On a @LEFT OUTER JOIN@ the entity on the right hand side may+-- not exist (i.e. there may be a @Person@ without any+-- @BlogPost@s), so while @p :: SqlExpr (Entity Person)@, we have+-- @mb :: SqlExpr (Maybe (Entity BlogPost))@. The whole+-- expression above has type @SqlPersist m [(Entity Person, Maybe+-- (Entity BlogPost))]@. Instead of using @(^.)@, we used+-- @('?.')@ to project a field from a @Maybe (Entity a)@.+--+-- We are by no means limited to joins of two tables, nor by+-- joins of different tables. For example, we may want a list+-- the @Follow@ entity:+--+-- @+-- SELECT P1.*, Follow.*, P2.*+-- FROM Person AS P1+-- INNER JOIN Follow ON P1.id = Follow.follower+-- INNER JOIN P2 ON P2.id = Follow.followed+-- @+--+-- In @esqueleto@, we may write the same query above as:+--+-- @+-- select $+-- from $ \\(p1 ``InnerJoin`` f ``InnerJoin`` p2) -> do+-- on (p2 ^. PersonId ==. f ^. FollowFollowed)+-- on (p1 ^. PersonId ==. f ^. FollowFollower)+-- return (p1, f, p2)+-- @+--+-- /Note carefully that the order of the ON clauses is/+-- /reversed!/ You're required to write your 'on's in reverse+-- order because that helps composability (see the documention of+-- 'on' for more details).+--+-- We also currently supports @UPDATE@ and @DELETE@ statements.+-- For example:+--+-- @+-- do 'update' $ \\p -> do+-- 'set' p [ PersonName '=.' val \"João\" ]+-- where_ (p ^. PersonName ==. val \"Joao\")+-- 'delete' $+-- from $ \\p -> do+-- where_ (p ^. PersonAge <. just (val 14))+-- @+++----------------------------------------------------------------------+++-- | Synonym for 'Database.Persist.Store.delete' that does not+-- clash with @esqueleto@'s 'delete'.+deleteKey :: (PersistStore backend m, PersistEntity val)+ => Key backend val -> backend m ()+deleteKey = Database.Persist.Store.delete++-- $reexports+--+-- We re-export @Database.Persist.Store@ for convenience, since+-- @esqueleto@ currently does not provide a way of doing+-- @insert@s or @update@s.
+ src/Database/Esqueleto/Internal/Language.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE DeriveDataTypeable+ , EmptyDataDecls+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , MultiParamTypeClasses+ , TypeFamilies+ , UndecidableInstances+ #-}+module Database.Esqueleto.Internal.Language+ ( Esqueleto(..)+ , from+ , InnerJoin(..)+ , CrossJoin(..)+ , LeftOuterJoin(..)+ , RightOuterJoin(..)+ , FullOuterJoin(..)+ , JoinKind(..)+ , IsJoinKind(..)+ , OnClauseWithoutMatchingJoinException(..)+ , PreprocessedFrom+ , OrderBy+ , Update+ ) where++import Control.Applicative (Applicative(..), (<$>))+import Control.Exception (Exception)+import Data.Typeable (Typeable)+import Database.Persist.GenericSql+import Database.Persist.Store+++-- | Finally tagless representation of @esqueleto@'s EDSL.+class (Functor query, Applicative query, Monad query) =>+ Esqueleto query expr backend | query -> expr backend, expr -> query backend where+ -- | (Internal) Start a 'from' query with an entity. 'from'+ -- does two kinds of magic using 'fromStart', 'fromJoin' and+ -- 'fromFinish':+ --+ -- 1. The simple but tedious magic of allowing tuples to be+ -- used.+ --+ -- 2. The more advanced magic of creating @JOIN@s. The+ -- @JOIN@ is processed from right to left. The rightmost+ -- entity of the @JOIN@ is created with 'fromStart'. Each+ -- @JOIN@ step is then translated into a call to 'fromJoin'.+ -- In the end, 'fromFinish' is called to materialize the+ -- @JOIN@.+ fromStart+ :: ( PersistEntity a+ , PersistEntityBackend a ~ backend )+ => query (expr (PreprocessedFrom (expr (Entity a))))+ -- | (Internal) Same as 'fromStart', but entity may be missing.+ fromStartMaybe+ :: ( PersistEntity a+ , PersistEntityBackend a ~ backend )+ => query (expr (PreprocessedFrom (expr (Maybe (Entity a)))))+ -- | (Internal) Do a @JOIN@.+ fromJoin+ :: IsJoinKind join+ => expr (PreprocessedFrom a)+ -> expr (PreprocessedFrom b)+ -> query (expr (PreprocessedFrom (join a b)))+ -- | (Internal) Finish a @JOIN@.+ fromFinish+ :: expr (PreprocessedFrom a)+ -> query a++ -- | @WHERE@ clause: restrict the query's result.+ where_ :: expr (Single Bool) -> query ()++ -- | @ON@ clause: restrict the a @JOIN@'s result. The @ON@+ -- clause will be applied to the /last/ @JOIN@ that does not+ -- have an @ON@ clause yet. If there are no @JOIN@s without+ -- @ON@ clauses (either because you didn't do any @JOIN@, or+ -- because all @JOIN@s already have their own @ON@ clauses), a+ -- runtime exception 'OnClauseWithoutMatchingJoinException' is+ -- thrown. @ON@ clauses are optional when doing @JOIN@s.+ --+ -- On the simple case of doing just one @JOIN@, for example+ --+ -- @+ -- select $+ -- from $ \(foo `InnerJoin` bar) -> do+ -- on (foo ^. FooId ==. bar ^. BarFooId)+ -- ...+ -- @+ --+ -- there's no ambiguity and the rules above just mean that+ -- you're allowed to call 'on' only once (as in SQL). If you+ -- have many joins, then the 'on's are applied on the /reverse/+ -- order that the @JOIN@s appear. For example:+ --+ -- @+ -- select $+ -- from $ \(foo `InnerJoin` bar `InnerJoin` baz) -> do+ -- on (baz ^. BazId ==. bar ^. BarBazId)+ -- on (foo ^. FooId ==. bar ^. BarFooId)+ -- ...+ -- @+ --+ -- The order is /reversed/ in order to improve composability.+ -- For example, consider @query1@ and @query2@ below:+ --+ -- @+ -- let query1 =+ -- from $ \(foo `InnerJoin` bar) -> do+ -- on (foo ^. FooId ==. bar ^. BarFooId)+ --+ -- query2 =+ -- from $ \(mbaz `LeftOuterJoin` quux) -> do+ -- return (mbaz ?. BazName, quux)+ --+ -- test1 = (,) <$> query1 <*> query2+ -- test2 = flip (,) <$> query2 <*> query1+ -- @+ --+ -- If the order was *not* reversed, then @test2@ would be+ -- broken: @query1@'s 'on' would refer to @query2@'s+ -- 'LeftOuterJoin'.+ on :: expr (Single Bool) -> query ()++ -- | @ORDER BY@ clause. See also 'asc' and 'desc'.+ orderBy :: [expr OrderBy] -> query ()++ -- | Ascending order of this field or expression.+ asc :: PersistField a => expr (Single a) -> expr OrderBy++ -- | Descending order of this field or expression.+ desc :: PersistField a => expr (Single a) -> expr OrderBy++ -- | Execute a subquery @SELECT@ in an expression.+ sub_select :: PersistField a => query (expr (Single a)) -> expr (Single a)++ -- | Execute a subquery @SELECT_DISTINCT@ in an expression.+ sub_selectDistinct :: PersistField a => query (expr (Single a)) -> expr (Single a)++ -- | Project a field of an entity.+ (^.) :: (PersistEntity val, PersistField typ) =>+ expr (Entity val) -> EntityField val typ -> expr (Single typ)++ -- | Project a field of an entity that may be null.+ (?.) :: (PersistEntity val, PersistField typ) =>+ expr (Maybe (Entity val)) -> EntityField val typ -> expr (Single (Maybe typ))++ -- | Lift a constant value from Haskell-land to the query.+ val :: PersistField typ => typ -> expr (Single typ)++ -- | @IS NULL@ comparison.+ isNothing :: PersistField typ => expr (Single (Maybe typ)) -> expr (Single Bool)++ -- | Analog to 'Just', promotes a value of type @typ@ into one+ -- of type @Maybe typ@. It should hold that @val . Just ===+ -- just . val@.+ just :: expr (Single typ) -> expr (Single (Maybe typ))++ -- | @NULL@ value.+ nothing :: expr (Single (Maybe typ))++ -- | @COUNT(*)@ value.+ countRows :: Num a => expr (Single a)++ not_ :: expr (Single Bool) -> expr (Single Bool)++ (==.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)+ (>=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)+ (>.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)+ (<=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)+ (<.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)+ (!=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)++ (&&.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool)+ (||.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool)++ (+.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a)+ (-.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a)+ (/.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a)+ (*.) :: PersistField a => expr (Single a) -> expr (Single a) -> expr (Single a)++ -- | @SET@ clause used on @UPDATE@s. Note that while it's not+ -- a type error to use this function on a @SELECT@, it will+ -- most certainly result in a runtime error.+ set :: PersistEntity val => expr (Entity val) -> [expr (Update val)] -> query ()++ (=.) :: (PersistEntity val, PersistField typ) => EntityField val typ -> expr (Single typ) -> expr (Update val)+ (+=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val)+ (-=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val)+ (*=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val)+ (/=.) :: (PersistEntity val, PersistField a) => EntityField val a -> expr (Single a) -> expr (Update val)+++-- Fixity declarations+infixl 9 ^.+infixl 7 *., /.+infixl 6 +., -.+infix 4 ==., >=., >., <=., <., !=.+infixr 3 &&., =., +=., -=., *=., /=.+infixr 2 ||.+infixr 2 `InnerJoin`, `CrossJoin`, `LeftOuterJoin`, `RightOuterJoin`, `FullOuterJoin`+++-- | Data type that represents an @INNER JOIN@ (see 'LeftOuterJoin' for an example).+data InnerJoin a b = a `InnerJoin` b++-- | Data type that represents an @CROSS JOIN@ (see 'LeftOuterJoin' for an example).+data CrossJoin a b = a `CrossJoin` b++-- | Data type that represents an @LEFT OUTER JOIN@. For example,+--+-- @+-- select $+-- from $ \(person `LeftOuterJoin` pet) ->+-- ...+-- @+--+-- is translated into+--+-- @+-- SELECT ...+-- FROM Person LEFT OUTER JOIN Pet+-- ...+-- @+data LeftOuterJoin a b = a `LeftOuterJoin` b++-- | Data type that represents an @RIGHT OUTER JOIN@ (see 'LeftOuterJoin' for an example).+data RightOuterJoin a b = a `RightOuterJoin` b++-- | Data type that represents an @FULL OUTER JOIN@ (see 'LeftOuterJoin' for an example).+data FullOuterJoin a b = a `FullOuterJoin` b+++-- | (Internal) A kind of @JOIN@.+data JoinKind =+ InnerJoinKind -- ^ @INNER JOIN@+ | CrossJoinKind -- ^ @CROSS JOIN@+ | LeftOuterJoinKind -- ^ @LEFT OUTER JOIN@+ | RightOuterJoinKind -- ^ @RIGHT OUTER JOIN@+ | FullOuterJoinKind -- ^ @FULL OUTER JOIN@+++-- | (Internal) Functions that operate on types (that should be)+-- of kind 'JoinKind'.+class IsJoinKind join where+ -- | (Internal) @smartJoin a b@ is a @JOIN@ of the correct kind.+ smartJoin :: a -> b -> join a b+ -- | (Internal) Reify a @JoinKind@ from a @JOIN@. This+ -- function is non-strict.+ reifyJoinKind :: join a b -> JoinKind+instance IsJoinKind InnerJoin where+ smartJoin a b = a `InnerJoin` b+ reifyJoinKind _ = InnerJoinKind+instance IsJoinKind CrossJoin where+ smartJoin a b = a `CrossJoin` b+ reifyJoinKind _ = CrossJoinKind+instance IsJoinKind LeftOuterJoin where+ smartJoin a b = a `LeftOuterJoin` b+ reifyJoinKind _ = LeftOuterJoinKind+instance IsJoinKind RightOuterJoin where+ smartJoin a b = a `RightOuterJoin` b+ reifyJoinKind _ = RightOuterJoinKind+instance IsJoinKind FullOuterJoin where+ smartJoin a b = a `FullOuterJoin` b+ reifyJoinKind _ = FullOuterJoinKind+++-- | Exception thrown whenever 'on' is used to create an @ON@+-- clause but no matching @JOIN@ is found.+data OnClauseWithoutMatchingJoinException =+ OnClauseWithoutMatchingJoinException String+ deriving (Eq, Ord, Show, Typeable)+instance Exception OnClauseWithoutMatchingJoinException where+++-- | (Internal) Phantom type used to process 'from' (see 'fromStart').+data PreprocessedFrom a+++-- | Phantom type used by 'orderBy', 'asc' and 'desc'.+data OrderBy+++-- | Phantom type for a @SET@ operation on an entity of the given+-- type (see 'set' and '(=.)').+data Update typ+++-- | @FROM@ clause: bring an entity into scope.+--+-- The following types implement 'from':+--+-- * @Expr (Entity val)@, which brings a single entity into scope.+--+-- * Tuples of any other types supported by 'from'. Calling+-- 'from' multiple times is the same as calling 'from' a+-- single time and using a tuple.+--+-- Note that using 'from' for the same entity twice does work+-- and corresponds to a self-join. You don't even need to use+-- two different calls to 'from', you may use a tuple.+from :: From query expr backend a => (a -> query b) -> query b+from = (from_ >>=)+++-- | (Internal) Class that implements the tuple 'from' magic (see+-- 'fromStart').+class Esqueleto query expr backend => From query expr backend a where+ from_ :: query a++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (expr (Entity val))+ ) => From query expr backend (expr (Entity val)) where+ from_ = fromPreprocess >>= fromFinish++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (expr (Maybe (Entity val)))+ ) => From query expr backend (expr (Maybe (Entity val))) where+ from_ = fromPreprocess >>= fromFinish++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (InnerJoin a b)+ ) => From query expr backend (InnerJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (CrossJoin a b)+ ) => From query expr backend (CrossJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (LeftOuterJoin a b)+ ) => From query expr backend (LeftOuterJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (RightOuterJoin a b)+ ) => From query expr backend (RightOuterJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend (FullOuterJoin a b)+ ) => From query expr backend (FullOuterJoin a b) where+ from_ = fromPreprocess >>= fromFinish++instance ( From query expr backend a+ , From query expr backend b+ ) => From query expr backend (a, b) where+ from_ = (,) <$> from_ <*> from_++instance ( From query expr backend a+ , From query expr backend b+ , From query expr backend c+ ) => From query expr backend (a, b, c) where+ from_ = (,,) <$> from_ <*> from_ <*> from_++instance ( From query expr backend a+ , From query expr backend b+ , From query expr backend c+ , From query expr backend d+ ) => From query expr backend (a, b, c, d) where+ from_ = (,,,) <$> from_ <*> from_ <*> from_ <*> from_++instance ( From query expr backend a+ , From query expr backend b+ , From query expr backend c+ , From query expr backend d+ , From query expr backend e+ ) => From query expr backend (a, b, c, d, e) where+ from_ = (,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_++instance ( From query expr backend a+ , From query expr backend b+ , From query expr backend c+ , From query expr backend d+ , From query expr backend e+ , From query expr backend f+ ) => From query expr backend (a, b, c, d, e, f) where+ from_ = (,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_++instance ( From query expr backend a+ , From query expr backend b+ , From query expr backend c+ , From query expr backend d+ , From query expr backend e+ , From query expr backend f+ , From query expr backend g+ ) => From query expr backend (a, b, c, d, e, f, g) where+ from_ = (,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_++instance ( From query expr backend a+ , From query expr backend b+ , From query expr backend c+ , From query expr backend d+ , From query expr backend e+ , From query expr backend f+ , From query expr backend g+ , From query expr backend h+ ) => From query expr backend (a, b, c, d, e, f, g, h) where+ from_ = (,,,,,,,) <$> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_ <*> from_++++-- | (Internal) Class that implements the @JOIN@ 'from' magic+-- (see 'fromStart').+class Esqueleto query expr backend => FromPreprocess query expr backend a where+ fromPreprocess :: query (expr (PreprocessedFrom a))++instance ( Esqueleto query expr backend+ , PersistEntity val+ , PersistEntityBackend val ~ backend+ ) => FromPreprocess query expr backend (expr (Entity val)) where+ fromPreprocess = fromStart++instance ( Esqueleto query expr backend+ , PersistEntity val+ , PersistEntityBackend val ~ backend+ ) => FromPreprocess query expr backend (expr (Maybe (Entity val))) where+ fromPreprocess = fromStartMaybe++instance ( Esqueleto query expr backend+ , FromPreprocess query expr backend a+ , FromPreprocess query expr backend b+ , IsJoinKind join+ ) => FromPreprocess query expr backend (join a b) where+ fromPreprocess = do+ a <- fromPreprocess+ b <- fromPreprocess+ fromJoin a b
+ src/Database/Esqueleto/Internal/Sql.hs view
@@ -0,0 +1,811 @@+{-# LANGUAGE ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , MultiParamTypeClasses+ , OverloadedStrings+ , UndecidableInstances+ #-}+module Database.Esqueleto.Internal.Sql+ ( SqlQuery+ , SqlExpr+ , select+ , selectSource+ , selectDistinct+ , selectDistinctSource+ , rawSelectSource+ , runSource+ , rawExecute+ , delete+ , update+ , toRawSql+ , Mode(..)+ ) where++import Control.Applicative (Applicative(..), (<$>))+import Control.Arrow ((***), first)+import Control.Exception (throw, throwIO)+import Control.Monad ((>=>), ap, MonadPlus(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Resource (MonadResourceBase)+import Data.List (intersperse)+import Data.Monoid (Monoid(..), (<>))+import Database.Persist.EntityDef+import Database.Persist.GenericSql+import Database.Persist.GenericSql.Internal (Connection(escapeName))+import Database.Persist.GenericSql.Raw (withStmt, execute)+import Database.Persist.Store hiding (delete)+import qualified Control.Monad.Trans.Reader as R+import qualified Control.Monad.Trans.State as S+import qualified Control.Monad.Trans.Writer as W+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import qualified Data.HashSet as HS+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++import Database.Esqueleto.Internal.Language+++-- | SQL backend for @esqueleto@ using 'SqlPersist'.+newtype SqlQuery a =+ Q { unQ :: W.WriterT SideData (S.State IdentState) a }++instance Functor SqlQuery where+ fmap f = Q . fmap f . unQ++instance Monad SqlQuery where+ return = Q . return+ m >>= f = Q (unQ m >>= unQ . f)++instance Applicative SqlQuery where+ pure = return+ (<*>) = ap+++----------------------------------------------------------------------+++-- | Side data written by 'SqlQuery'.+data SideData = SideData { sdFromClause :: ![FromClause]+ , sdSetClause :: ![SetClause]+ , sdWhereClause :: !WhereClause+ , sdOrderByClause :: ![OrderByClause]+ }++instance Monoid SideData where+ mempty = SideData mempty mempty mempty mempty+ SideData f s w o `mappend` SideData f' s' w' o' =+ SideData (f <> f') (s <> s') (w <> w') (o <> o')+++-- | A part of a @FROM@ clause.+data FromClause =+ FromStart Ident EntityDef+ | FromJoin FromClause JoinKind FromClause (Maybe (SqlExpr (Single Bool)))+ | OnClause (SqlExpr (Single Bool))+++-- | A part of a @SET@ clause.+newtype SetClause = SetClause (SqlExpr (Single ()))+++-- | Collect 'OnClause's on 'FromJoin's. Returns the first+-- unmatched 'OnClause's data on error. Returns a list without+-- 'OnClauses' on success.+collectOnClauses :: [FromClause] -> Either (SqlExpr (Single Bool)) [FromClause]+collectOnClauses = go []+ where+ go [] (f@(FromStart _ _):fs) = fmap (f:) (go [] fs) -- fast path+ go acc (OnClause expr :fs) = findMatching acc expr >>= flip go fs+ go acc (f:fs) = go (f:acc) fs+ go acc [] = return $ reverse acc++ findMatching (f : acc) expr =+ case tryMatch expr f of+ Just f' -> return (f' : acc)+ Nothing -> (f:) <$> findMatching acc expr+ findMatching [] expr = Left expr++ tryMatch expr (FromJoin l k r onClause) =+ matchR `mplus` matchC `mplus` matchL -- right to left+ where+ matchR = (\r' -> FromJoin l k r' onClause) <$> tryMatch expr r+ matchL = (\l' -> FromJoin l' k r onClause) <$> tryMatch expr l+ matchC = case onClause of+ Nothing -> return (FromJoin l k r (Just expr))+ Just _ -> mzero+ tryMatch _ _ = mzero+++-- | A complete @WHERE@ clause.+data WhereClause = Where (SqlExpr (Single Bool))+ | NoWhere++instance Monoid WhereClause where+ mempty = NoWhere+ NoWhere `mappend` w = w+ w `mappend` NoWhere = w+ Where e1 `mappend` Where e2 = Where (e1 &&. e2)+++-- | A @ORDER BY@ clause.+type OrderByClause = SqlExpr OrderBy+++----------------------------------------------------------------------+++-- | Identifier used for table names.+newtype Ident = I T.Text+++-- | List of identifiers already in use and supply of temporary+-- identifiers.+newtype IdentState = IdentState { inUse :: HS.HashSet T.Text }++initialIdentState :: IdentState+initialIdentState = IdentState mempty+++-- | Create a fresh 'Ident'. If possible, use the given+-- 'DBName'.+newIdentFor :: DBName -> SqlQuery Ident+newIdentFor = Q . lift . try . unDBName+ where+ try orig = do+ s <- S.get+ let go (t:ts) | t `HS.member` inUse s = go ts+ | otherwise = use t+ go [] = error "Esqueleto/Sql/newIdentFor: never here"+ go (possibilities orig)++ possibilities t = t : map addNum [2..]+ where+ addNum :: Int -> T.Text+ addNum = T.append t . T.pack . show++ use t = do+ S.modify (\s -> s { inUse = HS.insert t (inUse s) })+ return (I t)+++-- | Use an identifier.+useIdent :: Escape -> Ident -> TLB.Builder+useIdent esc (I ident) = esc (DBName ident)+++----------------------------------------------------------------------+++-- | An expression on the SQL backend.+data SqlExpr a where+ EEntity :: Ident -> SqlExpr (Entity val)+ EMaybe :: SqlExpr a -> SqlExpr (Maybe a)+ ERaw :: NeedParens -> (Escape -> (TLB.Builder, [PersistValue])) -> SqlExpr (Single a)+ EOrderBy :: OrderByType -> SqlExpr (Single a) -> SqlExpr OrderBy+ ESet :: (SqlExpr (Entity val) -> SqlExpr (Single ())) -> SqlExpr (Update val)+ EPreprocessedFrom :: a -> FromClause -> SqlExpr (PreprocessedFrom a)++data NeedParens = Parens | Never++parensM :: NeedParens -> TLB.Builder -> TLB.Builder+parensM Never = id+parensM Parens = parens++data OrderByType = ASC | DESC++type Escape = DBName -> TLB.Builder+++instance Esqueleto SqlQuery SqlExpr SqlPersist where+ fromStart = x+ where+ x = do+ let ed = entityDef (getVal x)+ ident <- newIdentFor (entityDB ed)+ let ret = EEntity ident+ from_ = FromStart ident ed+ return (EPreprocessedFrom ret from_)+ getVal :: SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) -> a+ getVal = error "Esqueleto/Sql/fromStart/getVal: never here"++ fromStartMaybe = maybelize <$> fromStart+ where+ maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))+ -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a))))+ maybelize (EPreprocessedFrom ret from_) = EPreprocessedFrom (EMaybe ret) from_+ maybelize _ = error "Esqueleto/Sql/fromStartMaybe: never here (see GHC #6124)"++ fromJoin (EPreprocessedFrom lhsRet lhsFrom)+ (EPreprocessedFrom rhsRet rhsFrom) = Q $ do+ let ret = smartJoin lhsRet rhsRet+ from_ = FromJoin lhsFrom -- LHS+ (reifyJoinKind ret) -- JOIN+ rhsFrom -- RHS+ Nothing -- ON+ return (EPreprocessedFrom ret from_)+ fromJoin _ _ = error "Esqueleto/Sql/fromJoin: never here (see GHC #6124)"++ fromFinish (EPreprocessedFrom ret from_) = Q $ do+ W.tell mempty { sdFromClause = [from_] }+ return ret+ fromFinish _ = error "Esqueleto/Sql/fromFinish: never here (see GHC #6124)"++ where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }++ on expr = Q $ W.tell mempty { sdFromClause = [OnClause expr] }++ orderBy exprs = Q $ W.tell mempty { sdOrderByClause = exprs }+ asc = EOrderBy ASC+ desc = EOrderBy DESC++ sub_select = sub SELECT+ sub_selectDistinct = sub SELECT_DISTINCT++ EEntity ident ^. field =+ ERaw Never $ \esc -> (useIdent esc ident <> ("." <> fieldName esc field), [])+ _ ^. _ = error "Esqueleto/Sql/(^.): never here (see GHC #6124)"++ EMaybe r ?. field = maybelize (r ^. field)+ where+ maybelize :: SqlExpr (Single a) -> SqlExpr (Single (Maybe a))+ maybelize (ERaw p f) = ERaw p f+ maybelize _ = error "Esqueleto/Sql/(?.): never here 1 (see GHC #6124)"+ _ ?. _ = error "Esqueleto/Sql/(?.): never here 2 (see GHC #6124)"++ val = ERaw Never . const . (,) "?" . return . toPersistValue++ isNothing (ERaw p f) = ERaw Never $ first ((<> " IS NULL") . parensM p) . f+ isNothing _ = error "Esqueleto/Sql/isNothing: never here (see GHC #6124)"+ just (ERaw p f) = ERaw p f+ just _ = error "Esqueleto/Sql/just: never here (see GHC #6124)"+ nothing = ERaw Never $ \_ -> ("NULL", mempty)+ countRows = ERaw Never $ \_ -> ("COUNT(*)", mempty)++ not_ (ERaw p f) = ERaw Never $ \esc -> let (b, vals) = f esc+ in ("NOT " <> parensM p b, vals)+ not_ _ = error "Esqueleto/Sql/not_: never here (see GHC #6124)"++ (==.) = binop " = "+ (>=.) = binop " >= "+ (>.) = binop " > "+ (<=.) = binop " <= "+ (<.) = binop " < "+ (!=.) = binop " != "+ (&&.) = binop " AND "+ (||.) = binop " OR "+ (+.) = binop " + "+ (-.) = binop " - "+ (/.) = binop " / "+ (*.) = binop " * "++ set ent upds = Q $ W.tell mempty { sdSetClause = map apply upds }+ where+ apply (ESet f) = SetClause (f ent)+ apply _ = error "Esqueleto/Sql/set/apply: never here (see GHC #6124)"++ field =. expr = setAux field (const expr)+ field +=. expr = setAux field (\ent -> ent ^. field +. expr)+ field -=. expr = setAux field (\ent -> ent ^. field -. expr)+ field *=. expr = setAux field (\ent -> ent ^. field *. expr)+ field /=. expr = setAux field (\ent -> ent ^. field /. expr)+++fieldName :: (PersistEntity val, PersistField typ)+ => Escape -> EntityField val typ -> TLB.Builder+fieldName esc = esc . fieldDB . persistFieldDef++setAux :: (PersistEntity val, PersistField typ)+ => EntityField val typ+ -> (SqlExpr (Entity val) -> SqlExpr (Single typ))+ -> SqlExpr (Update val)+setAux field mkVal = ESet $ \ent -> binop " = " name (mkVal ent)+ where name = ERaw Never $ \esc -> (fieldName esc field, mempty)++sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Single a)) -> SqlExpr (Single a)+sub mode query = ERaw Parens $ \esc -> first parens (toRawSql mode esc query)++fromDBName :: Connection -> DBName -> TLB.Builder+fromDBName conn = TLB.fromText . escapeName conn++binop :: TLB.Builder -> SqlExpr (Single a) -> SqlExpr (Single b) -> SqlExpr (Single c)+binop op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f+ where+ f esc = let (b1, vals1) = f1 esc+ (b2, vals2) = f2 esc+ in ( parensM p1 b1 <> op <> parensM p2 b2+ , vals1 <> vals2 )+binop _ _ _ = error "Esqueleto/Sql/binop: never here (see GHC #6124)"+++----------------------------------------------------------------------+++-- | (Internal) Execute an @esqueleto@ @SELECT@ 'SqlQuery' inside+-- @persistent@'s 'SqlPersist' monad.+rawSelectSource :: ( SqlSelect a r+ , MonadLogger m+ , MonadResourceBase m )+ => Mode+ -> SqlQuery a+ -> SqlPersist m (C.Source (C.ResourceT (SqlPersist m)) r)+rawSelectSource mode query = src+ where+ src = do+ conn <- SqlPersist R.ask+ return $ run conn C.$= massage++ run conn =+ uncurry withStmt $+ first (TL.toStrict . TLB.toLazyText) $+ toRawSql mode (fromDBName conn) query++ massage = do+ mrow <- C.await+ case process <$> mrow of+ Just (Right r) -> C.yield r >> massage+ Just (Left err) -> liftIO $ throwIO $ PersistMarshalError err+ Nothing -> return ()++ process = sqlSelectProcessRow+++-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s+-- 'SqlPersist' monad and return a 'C.Source' of rows.+selectSource :: ( SqlSelect a r+ , MonadLogger m+ , MonadResourceBase m )+ => SqlQuery a+ -> SqlPersist m (C.Source (C.ResourceT (SqlPersist m)) r)+selectSource = rawSelectSource SELECT+++-- | Execute an @esqueleto@ @SELECT@ query inside @persistent@'s+-- 'SqlPersist' monad and return a list of rows.+select :: ( SqlSelect a r+ , MonadLogger m+ , MonadResourceBase m )+ => SqlQuery a -> SqlPersist m [r]+select = selectSource >=> runSource+++-- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside+-- @persistent@'s 'SqlPersist' monad and return a 'C.Source' of+-- rows.+selectDistinctSource+ :: ( SqlSelect a r+ , MonadLogger m+ , MonadResourceBase m )+ => SqlQuery a+ -> SqlPersist m (C.Source (C.ResourceT (SqlPersist m)) r)+selectDistinctSource = rawSelectSource SELECT_DISTINCT+++-- | Execute an @esqueleto@ @SELECT DISTINCT@ query inside+-- @persistent@'s 'SqlPersist' monad and return a list of rows.+selectDistinct :: ( SqlSelect a r+ , MonadLogger m+ , MonadResourceBase m )+ => SqlQuery a -> SqlPersist m [r]+selectDistinct = selectDistinctSource >=> runSource+++-- | Runs a 'C.Source' of rows.+runSource :: MonadResourceBase m =>+ C.Source (C.ResourceT (SqlPersist m)) r+ -> SqlPersist m [r]+runSource src = C.runResourceT $ src C.$$ CL.consume+++----------------------------------------------------------------------+++-- | (Internal) Execute an @esqueleto@ statement inside+-- @persistent@'s 'SqlPersist' monad.+rawExecute :: ( MonadLogger m+ , MonadResourceBase m )+ => Mode+ -> SqlQuery ()+ -> SqlPersist m ()+rawExecute mode query = do+ conn <- SqlPersist R.ask+ uncurry execute $+ first (TL.toStrict . TLB.toLazyText) $+ toRawSql mode (fromDBName conn) query+++-- | Execute an @esqueleto@ @DELETE@ query inside @persistent@'s+-- 'SqlPersist' monad. Note that currently there are no type+-- checks for statements that should not appear on a @DELETE@+-- query.+--+-- Example of usage:+--+-- @+-- delete $+-- from $ \appointment ->+-- where_ (appointment ^. AppointmentDate <. val now)+-- @+delete :: ( MonadLogger m+ , MonadResourceBase m )+ => SqlQuery ()+ -> SqlPersist m ()+delete = rawExecute DELETE+++-- | Execute an @esqueleto@ @UPDATE@ query inside @persistent@'s+-- 'SqlPersist' monad. Note that currently there are no type+-- checks for statements that should not appear on a @UPDATE@+-- query.+--+-- Example of usage:+--+-- @+-- update $ \p -> do+-- set p [ PersonAge =. just (val thisYear) -. p ^. PersonBorn ]+-- where_ $ isNull (p ^. PersonAge)+-- @+update :: ( MonadLogger m+ , MonadResourceBase m+ , PersistEntity val+ , PersistEntityBackend val ~ SqlPersist )+ => (SqlExpr (Entity val) -> SqlQuery ())+ -> SqlPersist m ()+update = rawExecute UPDATE . from+++----------------------------------------------------------------------+++-- | Pretty prints a 'SqlQuery' into a SQL query.+toRawSql :: SqlSelect a r => Mode -> Escape -> SqlQuery a -> (TLB.Builder, [PersistValue])+toRawSql mode esc query =+ let (ret, SideData fromClauses setClauses whereClauses orderByClauses) =+ flip S.evalState initialIdentState $+ W.runWriterT $+ unQ query+ in mconcat+ [ makeSelect esc mode ret+ , makeFrom esc mode fromClauses+ , makeSet esc setClauses+ , makeWhere esc whereClauses+ , makeOrderBy esc orderByClauses+ ]++data Mode = SELECT | SELECT_DISTINCT | DELETE | UPDATE+++uncommas :: [TLB.Builder] -> TLB.Builder+uncommas = mconcat . intersperse ", "++uncommas' :: Monoid a => [(TLB.Builder, a)] -> (TLB.Builder, a)+uncommas' = (uncommas *** mconcat) . unzip+++makeSelect :: SqlSelect a r => Escape -> Mode -> a -> (TLB.Builder, [PersistValue])+makeSelect esc mode ret = first (s <>) (sqlSelectCols esc ret)+ where+ s = case mode of+ SELECT -> "SELECT "+ SELECT_DISTINCT -> "SELECT DISTINCT "+ DELETE -> "DELETE"+ UPDATE -> "UPDATE "+++makeFrom :: Escape -> Mode -> [FromClause] -> (TLB.Builder, [PersistValue])+makeFrom _ _ [] = mempty+makeFrom esc mode fs = ret+ where+ ret = case collectOnClauses fs of+ Left expr -> throw $ mkExc expr+ Right fs' -> keyword $ uncommas' (map (mk Never mempty) fs')+ keyword = case mode of+ UPDATE -> id+ _ -> first ("\nFROM " <>)++ mk _ onClause (FromStart i def) = base i def <> onClause+ mk paren onClause (FromJoin lhs kind rhs monClause) =+ first (parensM paren) $+ mconcat [ mk Parens onClause lhs+ , (fromKind kind, mempty)+ , mk Never (maybe mempty makeOnClause monClause) rhs+ ]+ mk _ _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)"++ base ident@(I identText) def =+ let db@(DBName dbText) = entityDB def+ in ( if dbText == identText+ then esc db+ else esc db <> (" AS " <> useIdent esc ident)+ , mempty )++ fromKind InnerJoinKind = " INNER JOIN "+ fromKind CrossJoinKind = " CROSS JOIN "+ fromKind LeftOuterJoinKind = " LEFT OUTER JOIN "+ fromKind RightOuterJoinKind = " RIGHT OUTER JOIN "+ fromKind FullOuterJoinKind = " FULL OUTER JOIN "++ makeOnClause (ERaw _ f) = first (" ON " <>) (f esc)+ makeOnClause _ = error "Esqueleto/Sql/makeFrom/makeOnClause: never here (see GHC #6124)"++ mkExc (ERaw _ f) =+ OnClauseWithoutMatchingJoinException $+ TL.unpack $ TLB.toLazyText $ fst (f esc)+ mkExc _ = OnClauseWithoutMatchingJoinException "???"+++makeSet :: Escape -> [SetClause] -> (TLB.Builder, [PersistValue])+makeSet _ [] = mempty+makeSet esc os = first ("\nSET " <>) $ uncommas' (map mk os)+ where+ mk (SetClause (ERaw _ f)) = f esc+ mk _ = error "Esqueleto/Sql/makeSet: never here (see GHC #6124)"+++makeWhere :: Escape -> WhereClause -> (TLB.Builder, [PersistValue])+makeWhere _ NoWhere = mempty+makeWhere esc (Where (ERaw _ f)) = first ("\nWHERE " <>) (f esc)+makeWhere _ _ = error "Esqueleto/Sql/makeWhere: never here (see GHC #6124)"+++makeOrderBy :: Escape -> [OrderByClause] -> (TLB.Builder, [PersistValue])+makeOrderBy _ [] = mempty+makeOrderBy esc os = first ("\nORDER BY " <>) $ uncommas' (map mk os)+ where+ mk (EOrderBy t (ERaw _ f)) = first (<> orderByType t) (f esc)+ mk _ = error "Esqueleto/Sql/makeOrderBy: never here (see GHC #6124)"+ orderByType ASC = " ASC"+ orderByType DESC = " DESC"+++parens :: TLB.Builder -> TLB.Builder+parens b = "(" <> (b <> ")")+++-- | Class for mapping results coming from 'SqlQuery' into actual+-- results.+--+-- This looks very similar to @RawSql@, and it is! However,+-- there are some crucial differences and ultimately they're+-- different classes.+class SqlSelect a r | a -> r, r -> a where+ -- | Creates the variable part of the @SELECT@ query and+ -- returns the list of 'PersistValue's that will be given to+ -- 'withStmt'.+ sqlSelectCols :: Escape -> a -> (TLB.Builder, [PersistValue])++ -- | Number of columns that will be consumed. Must be+ -- non-strict on the argument.+ sqlSelectColCount :: a -> Int++ -- | Transform a row of the result into the data type.+ sqlSelectProcessRow :: [PersistValue] -> Either T.Text r++instance SqlSelect () () where+ sqlSelectCols _ _ = mempty+ sqlSelectColCount _ = 0+ sqlSelectProcessRow _ = Right ()++instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where+ sqlSelectCols escape expr@(EEntity ident) = ret+ where+ process ed = uncommas $+ map ((name <>) . escape) $+ (entityID ed:) $+ map fieldDB $+ entityFields ed+ -- 'name' is the biggest difference between 'RawSql' and+ -- 'SqlSelect'. We automatically create names for tables+ -- (since it's not the user who's writing the FROM+ -- clause), while 'rawSql' assumes that it's just the+ -- name of the table (which doesn't allow self-joins, for+ -- example).+ name = useIdent escape ident <> "."+ ret = let ed = entityDef $ getEntityVal expr+ in (process ed, mempty)+ sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Entity]: never here (see GHC #6124)"+ sqlSelectColCount = (+1) . length . entityFields . entityDef . getEntityVal+ sqlSelectProcessRow (idCol:ent) =+ Entity <$> fromPersistValue idCol+ <*> fromPersistValues ent+ sqlSelectProcessRow _ = Left "SqlSelect (Entity a): wrong number of columns."++getEntityVal :: SqlExpr (Entity a) -> a+getEntityVal = error "Esqueleto/Sql/getEntityVal"++instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where+ sqlSelectCols escape (EMaybe ent) = sqlSelectCols escape ent+ sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Maybe Entity]: never here (see GHC #6124)"+ sqlSelectColCount = sqlSelectColCount . fromEMaybe+ where+ fromEMaybe :: SqlExpr (Maybe e) -> SqlExpr e+ fromEMaybe = error "Esqueleto/Sql/sqlSelectColCount[Maybe Entity]/fromEMaybe"+ sqlSelectProcessRow cols+ | all (== PersistNull) cols = return Nothing+ | otherwise = Just <$> sqlSelectProcessRow cols++instance PersistField a => SqlSelect (SqlExpr (Single a)) (Single a) where+ sqlSelectCols esc (ERaw p f) = let (b, vals) = f esc+ in (parensM p b, vals)+ sqlSelectCols _ _ = error "Esqueleto/Sql/sqlSelectCols[Single]: never here (see GHC #6124)"+ sqlSelectColCount = const 1+ sqlSelectProcessRow [pv] = Single <$> fromPersistValue pv+ sqlSelectProcessRow _ = Left "SqlSelect (Single a): wrong number of columns."++instance ( SqlSelect a ra+ , SqlSelect b rb+ ) => SqlSelect (a, b) (ra, rb) where+ sqlSelectCols esc (a, b) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ ]+ sqlSelectColCount ~(a,b) = sqlSelectColCount a + sqlSelectColCount b+ sqlSelectProcessRow =+ let x = getType processRow+ getType :: SqlSelect a r => (z -> Either y (r,x)) -> a+ getType = error "Esqueleto/SqlSelect[(a,b)]/sqlSelectProcessRow/getType"++ colCountFst = sqlSelectColCount x++ processRow row =+ let (rowFst, rowSnd) = splitAt colCountFst row+ in (,) <$> sqlSelectProcessRow rowFst+ <*> sqlSelectProcessRow rowSnd++ in colCountFst `seq` processRow+ -- Avoids recalculating 'colCountFst'.++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ ) => SqlSelect (a, b, c) (ra, rb, rc) where+ sqlSelectCols esc (a, b, c) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ ]+ sqlSelectColCount = sqlSelectColCount . from3+ sqlSelectProcessRow = fmap to3 . sqlSelectProcessRow++from3 :: (a,b,c) -> ((a,b),c)+from3 (a,b,c) = ((a,b),c)++to3 :: ((a,b),c) -> (a,b,c)+to3 ((a,b),c) = (a,b,c)+++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ ) => SqlSelect (a, b, c, d) (ra, rb, rc, rd) where+ sqlSelectCols esc (a, b, c, d) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ ]+ sqlSelectColCount = sqlSelectColCount . from4+ sqlSelectProcessRow = fmap to4 . sqlSelectProcessRow++from4 :: (a,b,c,d) -> ((a,b),(c,d))+from4 (a,b,c,d) = ((a,b),(c,d))++to4 :: ((a,b),(c,d)) -> (a,b,c,d)+to4 ((a,b),(c,d)) = (a,b,c,d)+++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ ) => SqlSelect (a, b, c, d, e) (ra, rb, rc, rd, re) where+ sqlSelectCols esc (a, b, c, d, e) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ ]+ sqlSelectColCount = sqlSelectColCount . from5+ sqlSelectProcessRow = fmap to5 . sqlSelectProcessRow++from5 :: (a,b,c,d,e) -> ((a,b),(c,d),e)+from5 (a,b,c,d,e) = ((a,b),(c,d),e)++to5 :: ((a,b),(c,d),e) -> (a,b,c,d,e)+to5 ((a,b),(c,d),e) = (a,b,c,d,e)+++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ ) => SqlSelect (a, b, c, d, e, f) (ra, rb, rc, rd, re, rf) where+ sqlSelectCols esc (a, b, c, d, e, f) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ ]+ sqlSelectColCount = sqlSelectColCount . from6+ sqlSelectProcessRow = fmap to6 . sqlSelectProcessRow++from6 :: (a,b,c,d,e,f) -> ((a,b),(c,d),(e,f))+from6 (a,b,c,d,e,f) = ((a,b),(c,d),(e,f))++to6 :: ((a,b),(c,d),(e,f)) -> (a,b,c,d,e,f)+to6 ((a,b),(c,d),(e,f)) = (a,b,c,d,e,f)+++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ ) => SqlSelect (a, b, c, d, e, f, g) (ra, rb, rc, rd, re, rf, rg) where+ sqlSelectCols esc (a, b, c, d, e, f, g) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ ]+ sqlSelectColCount = sqlSelectColCount . from7+ sqlSelectProcessRow = fmap to7 . sqlSelectProcessRow++from7 :: (a,b,c,d,e,f,g) -> ((a,b),(c,d),(e,f),g)+from7 (a,b,c,d,e,f,g) = ((a,b),(c,d),(e,f),g)++to7 :: ((a,b),(c,d),(e,f),g) -> (a,b,c,d,e,f,g)+to7 ((a,b),(c,d),(e,f),g) = (a,b,c,d,e,f,g)+++instance ( SqlSelect a ra+ , SqlSelect b rb+ , SqlSelect c rc+ , SqlSelect d rd+ , SqlSelect e re+ , SqlSelect f rf+ , SqlSelect g rg+ , SqlSelect h rh+ ) => SqlSelect (a, b, c, d, e, f, g, h) (ra, rb, rc, rd, re, rf, rg, rh) where+ sqlSelectCols esc (a, b, c, d, e, f, g, h) =+ uncommas'+ [ sqlSelectCols esc a+ , sqlSelectCols esc b+ , sqlSelectCols esc c+ , sqlSelectCols esc d+ , sqlSelectCols esc e+ , sqlSelectCols esc f+ , sqlSelectCols esc g+ , sqlSelectCols esc h+ ]+ sqlSelectColCount = sqlSelectColCount . from8+ sqlSelectProcessRow = fmap to8 . sqlSelectProcessRow++from8 :: (a,b,c,d,e,f,g,h) -> ((a,b),(c,d),(e,f),(g,h))+from8 (a,b,c,d,e,f,g,h) = ((a,b),(c,d),(e,f),(g,h))++to8 :: ((a,b),(c,d),(e,f),(g,h)) -> (a,b,c,d,e,f,g,h)+to8 ((a,b),(c,d),(e,f),(g,h)) = (a,b,c,d,e,f,g,h)
+ test/Test.hs view
@@ -0,0 +1,478 @@+{-# LANGUAGE ConstraintKinds+ , EmptyDataDecls+ , FlexibleContexts+ , GADTs+ , GeneralizedNewtypeDeriving+ , MultiParamTypeClasses+ , OverloadedStrings+ , QuasiQuotes+ , Rank2Types+ , TemplateHaskell+ , TypeFamilies+ #-}+module Main (main) where++import Control.Applicative (Applicative(..), (<$>))+import Control.Monad (replicateM_)+import Control.Monad.Base (MonadBase(..))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (MonadLogger(..), LogLevel(..))+import Control.Monad.Trans.Control (MonadBaseControl(..))+import Database.Esqueleto+import Database.Persist.Sqlite (withSqliteConn)+import Database.Persist.TH+import Language.Haskell.TH (Loc(..))+import System.IO (stderr)+import Test.Hspec++import qualified Control.Monad.Trans.Reader as R+import qualified Data.Conduit as C+import qualified Data.Text as T+import qualified System.Log.FastLogger as FL+++-- Test schema+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|+ Person+ name String+ age Int Maybe+ deriving Eq Show+ BlogPost+ title String+ authorId PersonId+ deriving Eq Show+ Follow+ follower PersonId+ followed PersonId+ deriving Eq Show+|]+++main :: IO ()+main = do+ let p1 = Person "John" (Just 36)+ p2 = Person "Rachel" Nothing+ p3 = Person "Mike" (Just 17)+ p4 = Person "Livia" (Just 17)+ hspec $ do+ describe "select" $ do+ it "works for a single value" $+ run $ do+ ret <- select $ return $ val (3 :: Int)+ liftIO $ ret `shouldBe` [ Single 3 ]++ it "works for a single NULL value" $+ run $ do+ ret <- select $ return $ nothing+ liftIO $ ret `shouldBe` [ Single (Nothing :: Maybe Int) ]++ describe "select/from" $ do+ it "works for a simple example" $+ run $ do+ p1e <- insert' p1+ ret <- select $+ from $ \person ->+ return person+ liftIO $ ret `shouldBe` [ p1e ]++ it "works for a simple self-join (one entity)" $+ run $ do+ p1e <- insert' p1+ ret <- select $+ from $ \(person1, person2) ->+ return (person1, person2)+ liftIO $ ret `shouldBe` [ (p1e, p1e) ]++ it "works for a simple self-join (two entities)" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ ret <- select $+ from $ \(person1, person2) ->+ return (person1, person2)+ liftIO $ ret `shouldBe` [ (p1e, p1e)+ , (p1e, p2e)+ , (p2e, p1e)+ , (p2e, p2e) ]++ it "works for a simple projection" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ ret <- select $+ from $ \p ->+ return (p ^. PersonId, p ^. PersonName)+ liftIO $ ret `shouldBe` [ (Single p1k, Single (personName p1))+ , (Single p2k, Single (personName p2)) ]++ it "works for a simple projection with a simple implicit self-join" $+ run $ do+ _ <- insert p1+ _ <- insert p2+ ret <- select $+ from $ \(pa, pb) ->+ return (pa ^. PersonName, pb ^. PersonName)+ liftIO $ ret `shouldBe` [ (Single (personName p1), Single (personName p1))+ , (Single (personName p1), Single (personName p2))+ , (Single (personName p2), Single (personName p1))+ , (Single (personName p2), Single (personName p2)) ]++ describe "select/JOIN" $ do+ it "works with a LEFT OUTER JOIN" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ b12e <- insert' $ BlogPost "b" (entityKey p1e)+ b11e <- insert' $ BlogPost "a" (entityKey p1e)+ b31e <- insert' $ BlogPost "c" (entityKey p3e)+ ret <- select $+ from $ \(p `LeftOuterJoin` mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ liftIO $ ret `shouldBe` [ (p1e, Just b11e)+ , (p1e, Just b12e)+ , (p4e, Nothing)+ , (p3e, Just b31e)+ , (p2e, Nothing) ]++ it "typechecks (A LEFT OUTER JOIN (B LEFT OUTER JOIN C))" $+ let _ = run $+ select $+ from $ \(a `LeftOuterJoin` (b `LeftOuterJoin` c)) ->+ let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]+ in return a+ in return () :: IO ()++ it "typechecks ((A LEFT OUTER JOIN B) LEFT OUTER JOIN C)" $+ let _ = run $+ select $+ from $ \((a `LeftOuterJoin` b) `LeftOuterJoin` c) ->+ let _ = [a, b, c] :: [ SqlExpr (Entity Person) ]+ in return a+ in return () :: IO ()++ it "throws an error for using on without joins" $+ run (select $+ from $ \(p, mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True)++ it "throws an error for using too many ons" $+ run (select $+ from $ \(p `FullOuterJoin` mb) -> do+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)+ orderBy [ asc (p ^. PersonName), asc (mb ?. BlogPostTitle) ]+ return (p, mb)+ ) `shouldThrow` (\(OnClauseWithoutMatchingJoinException _) -> True)++ describe "select/where_" $ do+ it "works for a simple example with (==.)" $+ run $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John")+ return p+ liftIO $ ret `shouldBe` [ p1e ]++ it "works for a simple example with (==.) and (||.)" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonName ==. val "John" ||. p ^. PersonName ==. val "Rachel")+ return p+ liftIO $ ret `shouldBe` [ p1e, p2e ]++ it "works for a simple example with (>.) [uses val . Just]" $+ run $ do+ p1e <- insert' p1+ _ <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (p ^. PersonAge >. val (Just 17))+ return p+ liftIO $ ret `shouldBe` [ p1e ]++ it "works for a simple example with (>.) and not_ [uses just . val]" $+ run $ do+ _ <- insert' p1+ _ <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ (not_ $ p ^. PersonAge >. just (val 17))+ return p+ liftIO $ ret `shouldBe` [ p3e ]++ it "works with isNothing" $+ run $ do+ _ <- insert' p1+ p2e <- insert' p2+ _ <- insert' p3+ ret <- select $+ from $ \p -> do+ where_ $ isNothing (p ^. PersonAge)+ return p+ liftIO $ ret `shouldBe` [ p2e ]++ it "works for a many-to-many implicit join" $+ run $ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ _ <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower, follows, followed) -> do+ where_ $ follower ^. PersonId ==. follows ^. FollowFollower &&.+ followed ^. PersonId ==. follows ^. FollowFollowed+ orderBy [ asc (follower ^. PersonName)+ , asc (followed ^. PersonName) ]+ return (follower, follows, followed)+ liftIO $ ret `shouldBe` [ (p1e, f11, p1e)+ , (p1e, f12, p2e)+ , (p4e, f42, p2e)+ , (p2e, f21, p1e) ]++ it "works for a many-to-many explicit join" $+ run $ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ _ <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower `InnerJoin` follows `InnerJoin` followed) -> do+ on $ followed ^. PersonId ==. follows ^. FollowFollowed+ on $ follower ^. PersonId ==. follows ^. FollowFollower+ orderBy [ asc (follower ^. PersonName)+ , asc (followed ^. PersonName) ]+ return (follower, follows, followed)+ liftIO $ ret `shouldBe` [ (p1e, f11, p1e)+ , (p1e, f12, p2e)+ , (p4e, f42, p2e)+ , (p2e, f21, p1e) ]++ it "works for a many-to-many explicit join with LEFT OUTER JOINs" $+ run $ do+ p1e@(Entity p1k _) <- insert' p1+ p2e@(Entity p2k _) <- insert' p2+ p3e <- insert' p3+ p4e@(Entity p4k _) <- insert' p4+ f12 <- insert' (Follow p1k p2k)+ f21 <- insert' (Follow p2k p1k)+ f42 <- insert' (Follow p4k p2k)+ f11 <- insert' (Follow p1k p1k)+ ret <- select $+ from $ \(follower `LeftOuterJoin` mfollows `LeftOuterJoin` mfollowed) -> do+ on $ mfollowed ?. PersonId ==. mfollows ?. FollowFollowed+ on $ just (follower ^. PersonId) ==. mfollows ?. FollowFollower+ orderBy [ asc ( follower ^. PersonName)+ , asc (mfollowed ?. PersonName) ]+ return (follower, mfollows, mfollowed)+ liftIO $ ret `shouldBe` [ (p1e, Just f11, Just p1e)+ , (p1e, Just f12, Just p2e)+ , (p4e, Just f42, Just p2e)+ , (p3e, Nothing, Nothing)+ , (p2e, Just f21, Just p1e) ]+++ describe "select/orderBy" $ do+ it "works with a single ASC field" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ ret <- select $+ from $ \p -> do+ orderBy [asc $ p ^. PersonName]+ return p+ liftIO $ ret `shouldBe` [ p1e, p3e, p2e ]++ it "works with two ASC fields" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonAge), asc (p ^. PersonName)]+ return p+ liftIO $ ret `shouldBe` [ p2e, p4e, p3e, p1e ]++ it "works with one ASC and one DESC field" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ p4e <- insert' p4+ ret <- select $+ from $ \p -> do+ orderBy [desc (p ^. PersonAge), asc (p ^. PersonName)]+ return p+ liftIO $ ret `shouldBe` [ p1e, p4e, p3e, p2e ]++ describe "selectDistinct" $+ it "works on a simple example" $+ run $ do+ p1k <- insert p1+ let (t1, t2, t3) = ("a", "b", "c")+ mapM_ (insert . flip BlogPost p1k) [t1, t3, t2, t2, t1]+ ret <- selectDistinct $+ from $ \b -> do+ let title = b ^. BlogPostTitle+ orderBy [asc title]+ return title+ liftIO $ ret `shouldBe` [ Single t1, Single t2, Single t3 ]++ describe "delete" $+ it "works on a simple example" $+ run $ do+ p1e <- insert' p1+ p2e <- insert' p2+ p3e <- insert' p3+ ret1 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ liftIO $ ret1 `shouldBe` [ p1e, p3e, p2e ]+ () <- delete $+ from $ \p ->+ where_ (p ^. PersonName ==. val (personName p1))+ ret2 <- select $+ from $ \p -> do+ orderBy [asc (p ^. PersonName)]+ return p+ liftIO $ ret2 `shouldBe` [ p3e, p2e ]++ describe "update" $ do+ it "works on a simple example" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ let anon = "Anonymous"+ () <- update $ \p -> do+ set p [ PersonName =. val anon+ , PersonAge *=. just (val 2) ]+ where_ (p ^. PersonName !=. val "Mike")+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName), asc (p ^. PersonAge) ]+ return p+ liftIO $ ret `shouldBe` [ Entity p2k (Person anon Nothing)+ , Entity p1k (Person anon (Just 72))+ , Entity p3k p3 ]++ it "works with a subexpression having COUNT(*)" $+ run $ do+ p1k <- insert p1+ p2k <- insert p2+ p3k <- insert p3+ replicateM_ 3 (insert $ BlogPost "" p1k)+ replicateM_ 7 (insert $ BlogPost "" p3k)+ let blogPostsBy p =+ from $ \b -> do+ where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)+ return countRows+ () <- update $ \p -> do+ set p [ PersonAge =. just (sub_select (blogPostsBy p)) ]+ ret <- select $+ from $ \p -> do+ orderBy [ asc (p ^. PersonName) ]+ return p+ liftIO $ ret `shouldBe` [ Entity p1k p1 { personAge = Just 3 }+ , Entity p3k p3 { personAge = Just 7 }+ , Entity p2k p2 { personAge = Just 0 } ]+++----------------------------------------------------------------------+++insert' :: (PersistEntity val, PersistStore (PersistEntityBackend val) m)+ => val -> PersistEntityBackend val m (Entity val)+insert' v = flip Entity v <$> insert v+++type RunDbMonad m = ( MonadBaseControl IO m, MonadIO m, MonadLogger m+ , C.MonadUnsafeIO m, C.MonadThrow m )+++run, runSilent, runVerbose :: (forall m. RunDbMonad m => SqlPersist (C.ResourceT m) a) -> IO a+runSilent act = run_worker act+runVerbose act = execVerbose $ run_worker act+run =+ if verbose+ then runVerbose+ else runSilent+++verbose :: Bool+verbose = False+++run_worker :: RunDbMonad m => SqlPersist (C.ResourceT m) a -> m a+run_worker =+ C.runResourceT .+ withSqliteConn ":memory:" .+ runSqlConn .+ (runMigrationSilent migrateAll >>)+++newtype Verbose a = Verbose { unVerbose :: R.ReaderT FL.Logger IO a }+ deriving (Functor, Applicative, Monad, MonadIO, C.MonadUnsafeIO, C.MonadThrow)++instance MonadBase IO Verbose where+ liftBase = Verbose . liftBase++instance MonadBaseControl IO Verbose where+ newtype StM Verbose a = StMV { unStMV :: StM (R.ReaderT FL.Logger IO) a }+ liftBaseWith f = Verbose . liftBaseWith $ \r -> f (fmap StMV . r . unVerbose)+ restoreM = Verbose . restoreM . unStMV++instance MonadLogger Verbose where+ monadLoggerLog loc level msg =+ Verbose $ do+ logger <- R.ask+ liftIO $ FL.loggerPutStr logger $+ [ FL.LB "["+ , FL.LS $ case level of+ LevelOther t -> T.unpack t+ _ -> drop 5 $ show level+ , FL.LB "] "+ , FL.toLogStr msg+ , FL.LB " @("+ , FL.LS $ (loc_package loc) +++ ':' : (loc_module loc) +++ ' ' : (loc_filename loc) +++ ':' : (show . fst $ loc_start loc) +++ ':' : (show . snd $ loc_start loc)+ , FL.LB ")\n"+ ]+++execVerbose :: Verbose a -> IO a+execVerbose (Verbose act) = do+ logger <- FL.mkLogger True stderr+ x <- R.runReaderT act logger+ FL.loggerFlush logger+ return x