diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/esqueleto.cabal b/esqueleto.cabal
new file mode 100644
--- /dev/null
+++ b/esqueleto.cabal
@@ -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
+ .
+ .
+ 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
diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/Esqueleto.hs
@@ -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
+-- () 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 () 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.
diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/Esqueleto/Internal/Language.hs
@@ -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
diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs
new file mode 100644
--- /dev/null
+++ b/src/Database/Esqueleto/Internal/Sql.hs
@@ -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)
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Test.hs
@@ -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