groundhog 0.2.0 → 0.3.0

raw patch · 19 files changed

+827/−620 lines, 19 filesdep +blaze-builderdep +mtldep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-builder, mtl

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Database/Groundhog.hs +2/−3
• Database/Groundhog/Core.hs +134/−104
• Database/Groundhog/Expression.hs +39/−33
• Database/Groundhog/Generic.hs +29/−5
• Database/Groundhog/Generic/Migration.hs +181/−127
• Database/Groundhog/Generic/PersistBackendHelpers.hs +115/−146
• Database/Groundhog/Generic/Sql.hs +169/−143
• Database/Groundhog/Generic/Sql/Functions.hs +37/−0
• Database/Groundhog/Instances.hs +36/−34
• examples/basic.hs +1/−1
• examples/dbSpecificTypes.hs +2/−2
• examples/embedded.hs +1/−1
• examples/keys.hs +12/−3
• examples/monadIntegration.hs +47/−0
• examples/projections.hs +10/−9
• examples/rawQueries.hs +1/−1
• examples/sumTypes.hs +1/−1
• examples/withoutQuasiQuotes.hs +4/−4
• groundhog.cabal +6/−3

@@ -21,7 +21,7 @@ -- - entity: Product -- |] -----main = withSqliteConn \":memory:\" $ runSqliteConn $ do+--main = withSqliteConn \":memory:\" $ runDbConn $ do --  -- Customer is also migrated because Product references it. --  -- It is possible to migrate schema for given type, e.g. migrate (undefined :: Customer String), or run migrateAll --  'runMigration' 'defaultMigrationLogger' migrateAll@@ -56,8 +56,7 @@   , (~>)   , limitTo   , offsetBy-  , orderBy-  , toArith)+  , orderBy) import Database.Groundhog.Expression as G import Database.Groundhog.Generic as G   ( createMigration

@@ -22,20 +22,21 @@   , HFalse   , HTrue   , ZT (..) -- ZonedTime wrapper+  , Utf8(..)+  , fromUtf8   , delim   -- * Constructing expressions   , Cond(..)   , ExprRelation(..)   , Update(..)   , (~>)-  , toArith   , FieldLike(..)+  , Assignable   , SubField(..)   , AutoKeyField(..)   , FieldChain   , NeverNull-  , Numeric-  , Arith(..)+  , UntypedExpr(..)   , Expr(..)   , Order(..)   , HasSelectOptions(..)@@ -47,11 +48,13 @@   , DbType(..)   , EntityDef(..)   , EmbeddedDef(..)+  , OtherTypeDef(..)   , ConstructorDef(..)   , Constructor(..)   , IsUniqueKey(..)   , UniqueDef(..)   , UniqueType(..)+  , ReferenceActionType(..)   -- * Migration   , SingleMigration   , NamedMigrations@@ -62,8 +65,14 @@   , RowPopper   , DbPersist(..)   , runDbPersist+  -- * Connections and transactions+  , ConnectionManager(..)+  , SingleConnectionManager+  , Savepoint(..)+  , runDbConn   ) where +import Blaze.ByteString.Builder (Builder, toByteString) import Control.Applicative (Applicative) import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Trans.Class (MonadTrans(..))@@ -71,6 +80,7 @@ import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..)) import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) import Control.Monad.Trans.State (StateT)+import Control.Monad.Reader (MonadReader(..)) import Control.Monad (liftM) import Data.ByteString.Char8 (ByteString) import Data.Int (Int64)@@ -120,26 +130,36 @@ data HTrue  -- | Represents condition for a query.-data Cond v (c :: (* -> *) -> *) =-    And (Cond v c) (Cond v c)-  | Or  (Cond v c) (Cond v c)-  | Not (Cond v c)-  | forall a b . Compare ExprRelation (Expr v c a) (Expr v c b)+data Cond db r =+    And (Cond db r) (Cond db r)+  | Or  (Cond db r) (Cond db r)+  | Not (Cond db r)+  | Compare ExprRelation (UntypedExpr db r) (UntypedExpr db r)+  | CondRaw (QueryRaw db r)  data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show -data Update v c = forall f a b . (FieldLike f (RestrictionHolder v c) a) => Update f (Expr v c b)+data Update db r = forall f a . Assignable f db r a => Update f (UntypedExpr db r)  -- | Defines sort order of a result-set-data Order v c = forall a f . (FieldLike f (RestrictionHolder v c) a) => Asc  f-               | forall a f . (FieldLike f (RestrictionHolder v c) a) => Desc f+data Order db r = forall a f . (FieldLike f db r a) => Asc  f+                | forall a f . (FieldLike f db r a) => Desc f +-- | It is used to map field to column names. It can be either a column name for a regular field of non-embedded type or a list of this field and the outer fields in reverse order. Eg, fieldChain $ SomeField ~> Tuple2_0Selector may result in [(\"val0\", DbString), (\"some\", DbEmbedded False [dbType \"\", dbType True])]. type FieldChain = ((String, DbType), [(String, EmbeddedDef)]) --- | Generalises data that can occur in expressions (so far there are Field and SubField).-class Projection f r a => FieldLike f r a | f -> r a where-  -- | It is used to map field to column names. It can be either a column name for a regular field of non-embedded type or a list of this field and the outer fields in reverse order. Eg, fieldChain $ SomeField ~> Tuple2_0Selector may result in Right [(\"val0\", DbString), (\"some\", DbEmbedded False [dbType \"\", dbType True])].-  -- Function fieldChain can be simplified to f v c a -> [(String, DbType)]. Datatype Either is used for optimisation of the common case, eg Field v c Int.+-- | Any data that can be fetched from a database+class PersistField a => Projection p db r a | p -> db r a where+  -- | It returns multiple expressions that can be transformed into values which can be selected. Difflist is used for concatenation efficiency.+  projectionExprs :: p -> [UntypedExpr db r] -> [UntypedExpr db r]+  -- | It is like 'fromPersistValues'. However, we cannot use it for projections in all cases. For the 'PersistEntity' instances 'fromPersistValues' expects entity id instead of the entity values.+  projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue])++-- | This subset of Projection instances is for things that behave like fields. Namely, they can occur in condition expressions (for example, Field and SubField) and on the left side of update statements. For example \"lower(field)\" is a valid Projection, but not Field like because it cannot be on the left side. Datatypes that index PostgreSQL arrays \"arr[5]\" or access composites \"(comp).subfield\" are valid instances of Assignable.+class Projection f db r a => Assignable f db r a | f -> r a++-- | This subset of Assignable is for plain database fields.+class Assignable f db r a => FieldLike f db r a | f -> r a where   fieldChain :: f -> FieldChain  class PersistField v => Embedded v where@@ -148,14 +168,14 @@  infixl 5 ~> -- | Accesses fields of the embedded datatypes. For example, @SomeField ==. (\"abc\", \"def\") ||. SomeField ~> Tuple2_0Selector ==. \"def\"@-(~>) :: (PersistEntity v, Constructor c, FieldLike f (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField v c a'+(~>) :: (PersistEntity v, Constructor c, FieldLike f db (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField v c a' field ~> sel = case fieldChain field of   ((name, typ), prefix) -> case typ of-    DbEmbedded emb@(EmbeddedDef _ ts)             -> SubField (ts !! selectorNum sel, (name, emb):prefix)-    DbEntity (Just (emb@(EmbeddedDef _ ts), _)) _ -> SubField (ts !! selectorNum sel, (name, emb):prefix)+    DbEmbedded emb@(EmbeddedDef _ ts)                 -> SubField (ts !! selectorNum sel, (name, emb):prefix)+    DbEntity (Just (emb@(EmbeddedDef _ ts), _)) _ _ _ -> SubField (ts !! selectorNum sel, (name, emb):prefix)     other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other -newtype SubField v (c :: (* -> *) -> *) a = SubField ((String, DbType), [(String, EmbeddedDef)])+newtype SubField v (c :: (* -> *) -> *) a = SubField FieldChain  -- | It can be used in expressions like a regular field. Note that the constructor should be specified for the condition. -- For example, @delete (AutoKeyField `asTypeOf` (undefined :: f v SomeConstructor) ==. k)@@@ -165,52 +185,45 @@  data RestrictionHolder v (c :: (* -> *) -> *) --- | Any data that can be fetched from a database-class Projection p r a | p -> r a where-  -- | It is like a 'fieldChain' for many fields. Difflist is used for concatenation efficiency.-  projectionFieldChains :: p -> [FieldChain] -> [FieldChain]-  -- | It is like 'fromPersistValues'. However, we cannot use it for projections in all cases. For the 'PersistEntity' instances 'fromPersistValues' expects entity id instead of the entity values.-  projectionResult :: PersistBackend m => p -> [PersistValue] -> m (a, [PersistValue])--data SelectOptions v c hasLimit hasOffset hasOrder = SelectOptions {-    condOptions   :: Cond v c+data SelectOptions db r hasLimit hasOffset hasOrder = SelectOptions {+    condOptions   :: Cond db r   , limitOptions  :: Maybe Int   , offsetOptions :: Maybe Int-  , orderOptions  :: [Order v c]+  , orderOptions  :: [Order db r]   } -class HasSelectOptions a v c | a -> v c where+class HasSelectOptions a db r | a -> db r where   type HasLimit a   type HasOffset a   type HasOrder a-  getSelectOptions :: a -> SelectOptions v c (HasLimit a) (HasOffset a) (HasOrder a)+  getSelectOptions :: a -> SelectOptions db r (HasLimit a) (HasOffset a) (HasOrder a) -instance HasSelectOptions (Cond v c) v c where-  type HasLimit (Cond v c) = HFalse-  type HasOffset (Cond v c) = HFalse-  type HasOrder (Cond v c) = HFalse+instance HasSelectOptions (Cond db r) db r where+  type HasLimit (Cond db r) = HFalse+  type HasOffset (Cond db r) = HFalse+  type HasOrder (Cond db r) = HFalse   getSelectOptions a = SelectOptions a Nothing Nothing [] -instance HasSelectOptions (SelectOptions v c hasLimit hasOffset hasOrder) v c where-  type HasLimit (SelectOptions v c hasLimit hasOffset hasOrder) = hasLimit-  type HasOffset (SelectOptions v c hasLimit hasOffset hasOrder) = hasOffset-  type HasOrder (SelectOptions v c hasLimit hasOffset hasOrder) = hasOrder+instance HasSelectOptions (SelectOptions db r hasLimit hasOffset hasOrder) db r where+  type HasLimit (SelectOptions db r hasLimit hasOffset hasOrder) = hasLimit+  type HasOffset (SelectOptions db r hasLimit hasOffset hasOrder) = hasOffset+  type HasOrder (SelectOptions db r hasLimit hasOffset hasOrder) = hasOrder   getSelectOptions = id -limitTo :: (HasSelectOptions a v c, HasLimit a ~ HFalse) => a -> Int -> SelectOptions v c HTrue (HasOffset a) (HasOrder a)+limitTo :: (HasSelectOptions a db r, HasLimit a ~ HFalse) => a -> Int -> SelectOptions db r HTrue (HasOffset a) (HasOrder a) limitTo opts lim = case getSelectOptions opts of   SelectOptions c _ off ord -> SelectOptions c (Just lim) off ord -offsetBy :: (HasSelectOptions a v c, HasOffset a ~ HFalse) => a -> Int -> SelectOptions v c (HasLimit a) HTrue (HasOrder a)+offsetBy :: (HasSelectOptions a db r, HasOffset a ~ HFalse) => a -> Int -> SelectOptions db r (HasLimit a) HTrue (HasOrder a) offsetBy opts off = case getSelectOptions opts of   SelectOptions c lim _ ord -> SelectOptions c lim (Just off) ord -orderBy :: (HasSelectOptions a v c, HasOrder a ~ HFalse) => a -> [Order v c] -> SelectOptions v c (HasLimit a) (HasOffset a) HTrue+orderBy :: (HasSelectOptions a db r, HasOrder a ~ HFalse) => a -> [Order db r] -> SelectOptions db r (HasLimit a) (HasOffset a) HTrue orderBy opts ord = case getSelectOptions opts of   SelectOptions c lim off _ -> SelectOptions c lim off ord  newtype Monad m => DbPersist conn m a = DbPersist { unDbPersist :: ReaderT conn m a }-  deriving (Monad, MonadIO, Functor, Applicative, MonadTrans)+  deriving (Monad, MonadIO, Functor, Applicative, MonadTrans, MonadReader conn)  instance MonadBase IO m => MonadBase IO (DbPersist conn m) where   liftBase = lift . liftBase@@ -228,15 +241,21 @@ runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a runDbPersist = runReaderT . unDbPersist -class PrimitivePersistField (AutoKeyType a) => DbDescriptor a where+class PrimitivePersistField (AutoKeyType db) => DbDescriptor db where   -- | Type of the database default autoincremented key. For example, Sqlite has Int64-  type AutoKeyType a+  type AutoKeyType db+  -- | Value of this type can be used as a part of a query. For example, it can be RenderS for relational databases, or BSON for MongoDB.+  type QueryRaw db :: * -> *+  -- | Name of backend+  backendName :: Proxy db -> String  class (Monad m, DbDescriptor (PhantomDb m)) => PersistBackend m where   -- | A token which defines the DB type. For example, different monads working with Sqlite, return Sqlite type.   type PhantomDb m-  -- | Insert a new record to a database and return its 'Key'+  -- | Insert a new record to a database and return its autogenerated key or ()   insert        :: PersistEntity v => v -> m (AutoKey v)+  -- | Insert a new record to a database. For some backends it may be faster than 'insert'.+  insert_       :: PersistEntity v => v -> m ()   -- | Try to insert a record and return Right newkey. If there is a constraint violation for the given constraint, Left oldkey is returned   -- , where oldkey is an identifier of the record with the matching values.   insertBy      :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v))@@ -246,7 +265,7 @@   -- | Replace a record with the given autogenerated key. Result is undefined if the record does not exist.   replace       :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> v -> m ()   -- | Return a list of the records satisfying the condition-  select        :: (PersistEntity v, Constructor c, HasSelectOptions opts v c)+  select        :: (PersistEntity v, Constructor c, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))                 => opts -> m [v]   -- | Return a list of all records. Order is undefined. It is useful for datatypes with multiple constructors.   selectAll     :: PersistEntity v => m [(AutoKey v, v)]@@ -255,17 +274,17 @@   -- | Fetch an entity from a database by its unique key   getBy         :: (PersistEntity v, IsUniqueKey (Key v (Unique u))) => Key v (Unique u) -> m (Maybe v)   -- | Update the records satisfying the condition-  update        :: (PersistEntity v, Constructor c) => [Update v c] -> Cond v c -> m ()+  update        :: (PersistEntity v, Constructor c) => [Update (PhantomDb m) (RestrictionHolder v c)] -> Cond (PhantomDb m) (RestrictionHolder v c) -> m ()   -- | Remove the records satisfying the condition-  delete        :: (PersistEntity v, Constructor c) => Cond v c -> m ()+  delete        :: (PersistEntity v, Constructor c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m ()   -- | Remove the record with given key. No-op if the record does not exist   deleteByKey   :: (PersistEntity v, PrimitivePersistField (Key v BackendSpecific)) => Key v BackendSpecific -> m ()   -- | Count total number of records satisfying the condition-  count         :: (PersistEntity v, Constructor c) => Cond v c -> m Int+  count         :: (PersistEntity v, Constructor c) => Cond (PhantomDb m) (RestrictionHolder v c) -> m Int   -- | Count total number of records with all constructors   countAll      :: PersistEntity v => v -> m Int   -- | Fetch projection of some fields-  project       :: (PersistEntity v, Constructor c, Projection p (RestrictionHolder v c) a', HasSelectOptions opts v c)+  project       :: (PersistEntity v, Constructor c, Projection p (PhantomDb m) (RestrictionHolder v c) a', HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))                 => p                 -> opts                 -> m [a']@@ -299,6 +318,8 @@ data EntityDef = EntityDef {   -- | Entity name. @entityName (entityDef v) == persistName v@     entityName   :: String+  -- | Database schema for the entity table and tables of its constructors+  , entitySchema :: Maybe String   -- | Named types of the instantiated polymorphic type parameters   , typeParams   :: [DbType]   -- | List of entity constructors definitions@@ -341,8 +362,15 @@ } deriving (Show, Eq)  -- | Defines how to treat the unique set of fields for a datatype-data UniqueType = UniqueConstraint | UniqueIndex deriving (Show, Eq)+data UniqueType = UniqueConstraint | UniqueIndex | UniquePrimary deriving (Show, Eq) +data ReferenceActionType = NoAction+                         | Restrict+                         | Cascade+                         | SetNull+                         | SetDefault+  deriving (Eq, Show)+ -- | A DB data type. Naming attempts to reflect the underlying Haskell -- datatypes, eg DbString instead of DbVarchar. Different databases may -- have different translations for these types.@@ -356,19 +384,38 @@             | DbDayTime             | DbDayTimeZoned             | DbBlob         -- ^ ByteString-            | DbOther String -- ^ Name for a database type+            | DbOther OtherTypeDef             -- More complex types             | DbMaybe DbType             | DbList String DbType -- ^ List table name and type of its argument             | DbEmbedded EmbeddedDef-            -- | Nothing means autokey, Just contains a unique key definition and a name of unique constraint.-            | DbEntity (Maybe (EmbeddedDef, String)) EntityDef+            -- | Nothing means autokey, Just contains a unique key definition and a name of unique constraint. Then there are actions on delete and on update.+            | DbEntity (Maybe (EmbeddedDef, String)) (Maybe ReferenceActionType) (Maybe ReferenceActionType) EntityDef   deriving (Eq, Show) +-- | Stores name for a database type+newtype OtherTypeDef = OtherTypeDef ((DbType -> String) -> String)++instance Eq OtherTypeDef where+  OtherTypeDef f1 == OtherTypeDef f2 = f1 show == f2 show++instance Show OtherTypeDef where+  showsPrec p (OtherTypeDef f) = showParen (p > 10) $ showString "OtherTypeDef " . showsPrec 11 (f show)+ -- | The first argument is a flag which defines if the field names should be concatenated with the outer field name (False) or used as is which provides full control over table column names (True). -- Value False should be the default value so that a datatype can be embedded without name conflict concern. The second argument list of field names and field types. data EmbeddedDef = EmbeddedDef Bool [(String, DbType)] deriving (Eq, Show) +-- | Datatype for incremental building SQL queries+newtype Utf8 = Utf8 Builder+instance Eq Utf8 where+  a == b = fromUtf8 a == fromUtf8 b+instance Show Utf8 where+  show = show . fromUtf8++fromUtf8 :: Utf8 -> ByteString+fromUtf8 (Utf8 a) = toByteString a+ -- | A raw value which can be stored in any backend and can be marshalled to -- and from a 'PersistField'. data PersistValue = PersistString String@@ -381,6 +428,8 @@                   | PersistUTCTime UTCTime                   | PersistZonedTime ZT                   | PersistNull+                  -- | Creating some datatypes may require calling a function, using a special constructor, or other syntax. The string (which can have placeholders) is included into query without escaping. The recursive constructions are not allowed, i.e., [PersistValue] cannot contain PersistCustom values.+                  | PersistCustom Utf8 [PersistValue]   deriving (Eq, Show)  -- | Avoid orphan instances.@@ -391,61 +440,24 @@ instance Ord ZT where     ZT a `compare` ZT b = zonedTimeToUTC a `compare` zonedTimeToUTC b --- | Arithmetic expressions which can include fields and literals-data Arith v c a =-    Plus  (Arith v c a) (Arith v c a)-  | Minus (Arith v c a) (Arith v c a)-  | Mult  (Arith v c a) (Arith v c a)-  | Abs   (Arith v c a)-  | forall f . (FieldLike f (RestrictionHolder v c) a) => ArithField f-  | Lit   Int64--instance (PersistEntity v, Constructor c) => Eq (Arith v c a) where-  (Plus a1 b1)   == (Plus a2 b2)   = a1 == a2 && b1 == b2-  (Minus a1 b1)  == (Minus a2 b2)  = a1 == a2 && b1 == b2-  (Mult a1 b1)   == (Mult a2 b2)   = a1 == a2 && b1 == b2-  (Abs a)        == (Abs b)        = a == b-  (ArithField a) == (ArithField b) = fieldChain a == fieldChain b-  (Lit a)        == (Lit b)        = a == b-  _              == _              = False--instance (PersistEntity v, Constructor c) => Show (Arith v c a) where-  show (Plus a b)     = "Plus (" ++ show a ++ ") (" ++ show b ++ ")"-  show (Minus a b)    = "Minus (" ++ show a ++ ") (" ++ show b ++ ")"-  show (Mult a b)     = "Mult (" ++ show a ++ ") (" ++ show b ++ ")"-  show (Abs a)        = "Abs (" ++ show a ++ ")"-  show (ArithField a) = "ArithField " ++ show (fieldChain a)-  show (Lit a)        = "Lit " ++ show a--instance (PersistEntity v, Constructor c, Numeric a) => Num (Arith v c a) where-  a + b       = Plus  a b-  a - b       = Minus a b-  a * b       = Mult  a b-  abs         = Abs-  signum      = error "no signum"-  fromInteger = Lit . fromInteger-  --- | Convert field to an arithmetic value-toArith :: (PersistEntity v, FieldLike f (RestrictionHolder v c) a') => f -> Arith v c a'-toArith = ArithField---- | Constraint for use in arithmetic expressions. 'Num' is not used to explicitly include only types supported by the library.--- TODO: consider replacement with 'Num'-class Numeric a---- | Types which when converted to 'PersistValue' are never NULL.+-- | Types which are never NULL when converted to 'PersistValue'. -- Consider the type @Maybe (Maybe a)@. Now Nothing is stored as NULL, so we cannot distinguish between Just Nothing and Nothing which is a problem. -- The purpose of this class is to ban the inner Maybe's. -- Maybe this class can be removed when support for inner Maybe's appears. class NeverNull a --- | Used to uniformly represent fields, constants and arithmetic expressions.--- A value should be converted to 'Expr' for usage in expressions-data Expr v c a where-  ExprField :: (PersistEntity v, FieldLike f (RestrictionHolder v c) a') => f -> Expr v c f-  ExprArith :: PersistEntity v => Arith v c a -> Expr v c (Arith v c a)-  ExprPure :: forall v c a . PurePersistField a => a -> Expr v c a+-- | Used to uniformly represent fields, constants and more complex things, e.g., arithmetic expressions.+-- A value should be converted to 'UntypedExpr' for usage in expressions+data UntypedExpr db r where+  ExprRaw :: forall db r a . PersistField a => Expr db r a -> UntypedExpr db r+  ExprField :: FieldChain -> UntypedExpr db r+  ExprPure :: forall db r a . PurePersistField a => a -> UntypedExpr db r +-- | Expr with phantom type helps to keep type safety in complex expressions+newtype Expr db r a = Expr (QueryRaw db r)+instance Show (Expr db r a) where show _ = "Expr"+instance Eq (Expr db r a) where (==) = error "(==): this instance Eq (Expr db r a) is made only for Num superclass constraint"+ -- | Represents everything which can be put into a database. This data can be stored in multiple columns and tables. To get value of those columns we might need to access another table. That is why the result type is monadic. class PersistField a where   -- | Return name of the type. If it is polymorhic, the names of parameter types are separated with 'Database.Groundhog.Generic.delim' symbol@@ -475,3 +487,21 @@  delim :: Char delim = '#'++-- | Connection manager provides connection to the passed function handles transations. Manager can be a connection itself, a pool, Snaplet in Snap, foundation datatype in Yesod, etc.+class ConnectionManager cm conn | cm -> conn where+  -- | Extracts the connection from manager and opens the transaction.+  withConn :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a+  -- | Extracts the connection.+  withConnNoTransaction :: (MonadBaseControl IO m, MonadIO m) => (conn -> m a) -> cm -> m a++-- | This connection manager always returns the same connection. This constraint is useful when performing operations which make sense only within one connection, for example, nested savepoints..+class ConnectionManager cm conn => SingleConnectionManager cm conn++class Savepoint conn where+  -- | Wraps the passed action into a named savepoint+  withConnSavepoint :: (MonadBaseControl IO m, MonadIO m) => String -> m a -> conn -> m a++-- | Runs action within connection. It can handle a simple connection, a pool of them, etc.+runDbConn :: (MonadBaseControl IO m, MonadIO m, ConnectionManager cm conn) => DbPersist conn m a -> cm -> m a+runDbConn = withConn . runDbPersist

@@ -12,6 +12,8 @@ 
 module Database.Groundhog.Expression
   ( Expression(..)
+  , Unifiable
+  , ExpressionOf
   , (=.)
   , (&&.), (||.)
   , (==.), (/=.), (<.), (<=.), (>.), (>=.)
@@ -21,27 +23,31 @@ import Database.Groundhog.Instances ()
 
 -- | Instances of this type can be converted to 'Expr'. It is useful for uniform manipulation over fields and plain values
-class Expression a v c where
-  toExpression :: a -> Expr v c a
+class Expression db r a where
+  toExpr :: a -> UntypedExpr db r
 
-instance PurePersistField a => Expression a v c where
-  toExpression = ExprPure
+class (Expression db r a, Unifiable a a') => ExpressionOf db r a a'
 
-instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Arith v c a) v' c' where
-  toExpression = ExprArith
+instance (Expression db r a, Unifiable a a') => ExpressionOf db r a a'
 
-instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Field v c a) v' c' where
-  toExpression = ExprField
+instance PurePersistField a => Expression db r a where
+  toExpr = ExprPure
 
-instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (SubField v c a) v' c' where
-  toExpression = ExprField
+instance (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where
+  toExpr = ExprRaw
 
-instance (PersistEntity v, Constructor c, PersistField (Key v' BackendSpecific), FieldLike (AutoKeyField v c) (RestrictionHolder v c) a', v ~ v', c ~ c') => Expression (AutoKeyField v c) v' c' where
-  toExpression = ExprField
+instance (PersistEntity v, Constructor c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
+  toExpr = ExprField . fieldChain
 
-instance (PersistEntity v, Constructor c, FieldLike (u (UniqueMarker v)) (RestrictionHolder v c) a', c' ~ UniqueConstr (Key v' (Unique u)), v ~ v', IsUniqueKey (Key v' (Unique u)), c ~ c') => Expression (u (UniqueMarker v)) v' c' where
-  toExpression = ExprField
+instance (PersistEntity v, Constructor c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (SubField v c a) where
+  toExpr = ExprField . fieldChain
 
+instance (PersistEntity v, Constructor c, PersistField (Key v BackendSpecific), FieldLike (AutoKeyField v c) db r' a') => Expression db r' (AutoKeyField v c) where
+  toExpr = ExprField . fieldChain
+
+instance (PersistEntity v, FieldLike (u (UniqueMarker v)) db r' a', r' ~ RestrictionHolder v (UniqueConstr (Key v (Unique u))),  IsUniqueKey (Key v (Unique u))) => Expression db r' (u (UniqueMarker v)) where
+  toExpr = ExprField . fieldChain
+
 -- Let's call "plain type" the types that uniquely define type of a Field it is compared to.
 -- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity)
 class Unifiable a b
@@ -53,9 +59,9 @@ instance (ExtractValue t (isPlain, r), NormalizeValue counterpart isPlain r r') => Normalize counterpart t r'
 
 class ExtractValue t r | t -> r
-instance r ~ (HFalse, a) => ExtractValue (Arith v c a) r
 instance r ~ (HFalse, a) => ExtractValue (Field v c a) r
 instance r ~ (HFalse, a) => ExtractValue (SubField v c a) r
+instance r ~ (HFalse, a) => ExtractValue (Expr db r' a) r
 instance r ~ (HFalse, Key v BackendSpecific) => ExtractValue (AutoKeyField v c) r
 instance r ~ (HFalse, Key v (Unique u)) => ExtractValue (u (UniqueMarker v)) r
 instance r ~ (HTrue, a) => ExtractValue a r
@@ -90,17 +96,17 @@ -- | Update field
 infixr 3 =.
 (=.) ::
-  ( Expression b v c
-  , FieldLike f (RestrictionHolder v c) a'
+  ( FieldLike f db r a'
+  , Expression db r b
   , Unifiable f b)
-  => f -> b -> Update v c
-f =. b = Update f (toExpression b)
+  => f -> b -> Update db r
+f =. b = Update f (toExpr b)
 
 -- | Boolean \"and\" operator.
-(&&.) :: Cond v c -> Cond v c -> Cond v c
+(&&.) :: Cond db r -> Cond db r -> Cond db r
 
 -- | Boolean \"or\" operator.  
-(||.) :: Cond v c -> Cond v c -> Cond v c
+(||.) :: Cond db r -> Cond db r -> Cond db r
 
 infixr 3 &&.
 a &&. b = And a b
@@ -109,21 +115,21 @@ a ||. b = Or a b
 
 (==.), (/=.) ::
-  ( Expression a v c
-  , Expression b v c
+  ( Expression db r a
+  , Expression db r b
   , Unifiable a b)
-  => a -> b -> Cond v c
+  => a -> b -> Cond db r
 
 (<.), (<=.), (>.), (>=.) ::
-  ( Expression a v c
-  , Expression b v c
+  ( Expression db r a
+  , Expression db r b
   , Unifiable a b)
-  => a -> b -> Cond v c
+  => a -> b -> Cond db r
 
 infix 4 ==., <., <=., >., >=.
-a ==. b = Compare Eq (toExpression a) (toExpression b)
-a /=. b = Compare Ne (toExpression a) (toExpression b)
-a <.  b = Compare Lt (toExpression a) (toExpression b)
-a <=. b = Compare Le (toExpression a) (toExpression b)
-a >.  b = Compare Gt (toExpression a) (toExpression b)
-a >=. b = Compare Ge (toExpression a) (toExpression b)
+a ==. b = Compare Eq (toExpr a) (toExpr b)
+a /=. b = Compare Ne (toExpr a) (toExpr b)
+a <.  b = Compare Lt (toExpr a) (toExpr b)
+a <=. b = Compare Le (toExpr a) (toExpr b)
+a >.  b = Compare Gt (toExpr a) (toExpr b)
+a >=. b = Compare Ge (toExpr a) (toExpr b)

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}  -- | This helper module is intended for use by the backend creators module Database.Groundhog.Generic@@ -14,7 +14,11 @@   , silentMigrationLogger   , defaultMigrationLogger   , failMessage-  -- * Helper functions defining *PersistValue instances+  -- * Helpers for running Groundhog within custom monads+  , HasConn+  , runDb+  , withSavepoint+  -- * Helper functions for defining *PersistValue instances   , primToPersistValue   , primFromPersistValue   , pureToPersistValue@@ -33,6 +37,7 @@   , onException   , PSEmbeddedFieldDef(..)   , applyEmbeddedDbTypeSettings+  , applyReferencesSettings   , findOne   , replaceOne   , matchElements@@ -49,6 +54,7 @@ import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM) import qualified Control.Exception as E import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader.Class (MonadReader(..)) import Data.Either (partitionEithers) import Data.Function (on) import Data.List (partition, sortBy)@@ -155,8 +161,8 @@  applyEmbeddedDbTypeSettings :: [PSEmbeddedFieldDef] -> DbType -> DbType applyEmbeddedDbTypeSettings settings typ = (case typ of-  DbEmbedded emb                 -> DbEmbedded $ applyToDef emb-  DbEntity (Just (emb, uniq)) e -> DbEntity (Just (applyToDef emb, uniq)) e+  DbEmbedded emb -> DbEmbedded $ applyToDef emb+  DbEntity (Just (emb, uniq)) onDel onUpd e -> DbEntity (Just (applyToDef emb, uniq)) onDel onUpd e   t -> error $ "applyEmbeddedDbTypeSettings: expected DbEmbedded, got " ++ show t) where   applyToDef (EmbeddedDef _ fields) = EmbeddedDef True $ go settings fields   go [] fs = fs@@ -165,7 +171,7 @@     Just (rest, PSEmbeddedFieldDef _ dbName dbTypeName subs) -> (fromMaybe fName dbName, typ'):go rest fs where       typ' = case (subs, dbTypeName) of         (Just e, _) -> applyEmbeddedDbTypeSettings e fType-        (_, Just typeName) -> DbOther typeName+        (_, Just typeName) -> DbOther (OtherTypeDef $ const typeName)         _ -> fType     Nothing -> f:go st fs   find :: String -> [PSEmbeddedFieldDef] -> Maybe ([PSEmbeddedFieldDef], PSEmbeddedFieldDef)@@ -173,6 +179,12 @@   find name (def:defs) | psEmbeddedFieldName def == name = Just (defs, def)                        | otherwise = fmap (\(defs', result) -> (def:defs', result)) $ find name defs +applyReferencesSettings :: Maybe ReferenceActionType -> Maybe ReferenceActionType -> DbType -> DbType+applyReferencesSettings onDel onUpd typ = case typ of+  DbEntity k _ _ e -> DbEntity k onDel onUpd e+  DbMaybe (DbEntity k _ _ e) -> DbMaybe (DbEntity k onDel onUpd e)+  t -> error $ "applyReferencesSettings: expected DbEntity, got " ++ show t+ primToPersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m ([PersistValue] -> [PersistValue]) primToPersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a:) @@ -254,3 +266,15 @@ isSimple :: [ConstructorDef] -> Bool isSimple [_] = True isSimple _   = False++-- | This class helps to shorten the type signatures of user monadic code.+class (MonadIO m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn+instance (MonadIO m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn++-- | It helps to run database operations within your application monad.+runDb :: HasConn m cm conn => DbPersist conn IO a -> m a+runDb f = ask >>= liftIO . runDbConn f++-- | It helps to run 'withConnSavepoint' within a monad.+withSavepoint :: (HasConn m cm conn, SingleConnectionManager cm conn, Savepoint conn) => String -> m a -> m a+withSavepoint name m = ask >>= withConnNoTransaction (withConnSavepoint name m)

@@ -3,23 +3,26 @@ module Database.Groundhog.Generic.Migration   ( Column(..)   , UniqueDef'(..)-  , Reference+  , Reference(..)   , TableInfo(..)   , AlterColumn(..)-  , AlterColumn'   , AlterTable(..)   , AlterDB(..)   , MigrationPack(..)+  , SchemaAnalyzer(..)   , mkColumns   , migrateRecursively   , migrateEntity   , migrateList   , getAlters   , defaultMigConstr+  , showReferenceAction+  , readReferenceAction   ) where  import Database.Groundhog.Core import Database.Groundhog.Generic+import Database.Groundhog.Generic.Sql (tableName)  import Control.Arrow ((***), (&&&)) import Control.Monad (liftM)@@ -30,63 +33,72 @@ import Data.List (group, intercalate) import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList) --- Describes a database column. Field cType always contains DbType that maps to one column (no DbEmbedded) data Column = Column     { colName :: String     , colNull :: Bool-    , colType :: DbType+    , colType :: DbType -- ^ contains DbType that maps to one column (no DbEmbedded)     , colDefault :: Maybe String     } deriving (Eq, Show) --- | Foreign table name and names of the corresponding columns-type Reference = (String, [(String, String)])+data Reference = Reference {+    referencedTableSchema :: Maybe String+  , referencedTableName :: String+  , referencedColumns :: [(String, String)] -- ^ child column, parent column+  , referenceOnDelete :: Maybe ReferenceActionType+  , referenceOnUpdate :: Maybe ReferenceActionType+  } deriving Show  data TableInfo = TableInfo {-    tablePrimaryKeyName :: Maybe String-  , tableColumns :: [Column]+    tableColumns :: [Column]   , tableUniques :: [UniqueDef']     -- | constraint name and reference   , tableReferences :: [(Maybe String, Reference)] } deriving Show -data AlterColumn = Type DbType | IsNull | NotNull | Add Column | Drop | AddPrimaryKey+data AlterColumn = Type DbType | IsNull | NotNull                  | Default String | NoDefault | UpdateValue String deriving Show -type AlterColumn' = (String, AlterColumn)- data AlterTable = AddUnique UniqueDef'                 | DropConstraint String                 | DropIndex String                 | AddReference Reference                 | DropReference String-                | AlterColumn AlterColumn' deriving Show+                | DropColumn String+                | AddColumn Column+                | AlterColumn Column [AlterColumn] deriving Show  data AlterDB = AddTable String-             -- | Table name, create statement, structure of table from DB, structure of table from datatype, alters-             | AlterTable String String TableInfo TableInfo [AlterTable]-             -- | Trigger name, table name-             | DropTrigger String String-             -- | Trigger name, table name, body-             | AddTriggerOnDelete String String String-             -- | Trigger name, table name, field name, body-             | AddTriggerOnUpdate String String String String+             -- | Table schema, table name, create statement, structure of table from DB, structure of table from datatype, alters+             | AlterTable (Maybe String) String String TableInfo TableInfo [AlterTable]+             -- | Trigger schema, trigger name, table schema, table name+             | DropTrigger (Maybe String) String (Maybe String) String+             -- | Trigger schema, trigger name, table schema, table name, body+             | AddTriggerOnDelete (Maybe String) String (Maybe String) String String+             -- | Trigger schema, trigger name, table schema, table name, field name, body+             | AddTriggerOnUpdate (Maybe String) String (Maybe String) String (Maybe String) String+             -- | Statement which creates the function              | CreateOrReplaceFunction String-             | DropFunction String+             -- | Function schema, function name+             | DropFunction (Maybe String) String   deriving Show -data UniqueDef' = UniqueDef' String UniqueType [String] deriving Show+data UniqueDef' = UniqueDef' {+    uniqueDefName :: Maybe String+  , uniqueDefType :: UniqueType+  , uniqueDefColumns :: [String]+} deriving Show  data MigrationPack m = MigrationPack {     compareTypes :: DbType -> DbType -> Bool   , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool   , compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-  , checkTable :: String -> m (Maybe (Either [String] TableInfo))-  , migTriggerOnDelete :: String -> [(String, String)] -> m (Bool, [AlterDB])-  , migTriggerOnUpdate :: String -> String -> String -> m (Bool, [AlterDB])-  , migConstr :: MigrationPack m -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)+  , migTriggerOnDelete :: Maybe String -> String -> [(String, String)] -> m (Bool, [AlterDB])+  , migTriggerOnUpdate :: Maybe String -> String -> [(String, String)] -> m [(Bool, [AlterDB])]+  , migConstr :: MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)   , escape :: String -> String-  , primaryKeyType :: String-  , foreignKeyType :: String+  , primaryKeyType :: DbType+  , primaryKeyTypeName :: String+  , foreignKeyTypeName :: String   , mainTableId :: String   , defaultPriority :: Int   -- | Sql pieces for the create table statement that add constraints and alterations for running after the table is created@@ -95,31 +107,32 @@   , showAlterDb :: AlterDB -> SingleMigration } -mkColumns :: (DbType -> DbType) -> String -> DbType -> ([Column], [Reference])-mkColumns mkType columnName dbtype = go "" (columnName, dbtype) where+mkColumns :: String -> DbType -> ([Column], [Reference])+mkColumns columnName dbtype = go "" (columnName, dbtype) where   go prefix (fname, typ) = (case typ of     DbEmbedded (EmbeddedDef False ts) -> concatMap' (go $ prefix ++ fname ++ [delim]) ts     DbEmbedded (EmbeddedDef True  ts) -> concatMap' (go "") ts     DbMaybe a      -> case go prefix (fname, a) of       ([c], refs) -> ([c {colNull = True}], refs)       _ -> error $ "mkColumns: datatype inside DbMaybe must be one column " ++ show a-    DbEntity (Just (emb, uName)) e  -> (cols, ref:refs) where+    DbEntity (Just (emb, uName)) onDel onUpd e  -> (cols, ref:refs) where       (cols, refs) = go prefix (fname, DbEmbedded emb)-      ref = (entityName e, zipWith' (curry $ colName *** colName) cols foreignColumns)+      ref = Reference (entitySchema e) (entityName e) (zipWith' (curry $ colName *** colName) cols foreignColumns) onDel onUpd       cDef = case constructors e of         [cDef'] -> cDef'         _       -> error "mkColumns: datatype with unique key cannot have more than one constructor"       UniqueDef _ _ uFields = findOne "unique" id uniqueName uName $ constrUniques cDef       fields = map (\(fName, _) -> findOne "field" id fst fName $ constrParams cDef) uFields       (foreignColumns, _) = concatMap' (go "") fields-    t@(DbEntity Nothing e) -> ([Column name False (mkType t) Nothing], refs) where-      refs = [(entityName e, [(name, keyName)])]+    t@(DbEntity Nothing onDel onUpd e) -> ([Column name False t Nothing], refs) where+      refs = [Reference (entitySchema e) (entityName e) [(name, keyName)] onDel onUpd]       keyName = case constructors e of         [cDef] -> fromMaybe (error "mkColumns: autokey name is Nothing") $ constrAutoKeyName cDef         _      -> "id"-    t@(DbList lName _) -> ([Column name False (mkType t) Nothing], refs) where-      refs = [(lName, [(name, "id")])]-    t -> ([Column name False (mkType t) Nothing], [])) where+    t@(DbList lName _) -> ([Column name False t Nothing], refs) where+      -- TODO: schema+      refs = [Reference Nothing lName [(name, "id")] Nothing Nothing]+    t -> ([Column name False t Nothing], [])) where       name = prefix ++ fname       concatMap' f xs = concat *** concat $ unzip $ map f xs       zipWith' _ [] [] = []@@ -136,7 +149,7 @@   -> StateT NamedMigrations m () migrateRecursively migE migL = go . dbType where   go l@(DbList lName t) = f lName (migL l) (go t)-  go (DbEntity _ e)     = f (entityName e) (migE e) (mapM_ go (allSubtypes e))+  go (DbEntity _ _ _ e) = f (entityName e) (migE e) (mapM_ go (allSubtypes e))   go (DbMaybe t)        = go t   go (DbEmbedded (EmbeddedDef _ ts))  = mapM_ (go . snd) ts   go _                  = return ()    -- ordinary types need not migration@@ -147,35 +160,35 @@       _ -> return ()   allSubtypes = map snd . concatMap constrParams . constructors -migrateEntity :: Monad m => MigrationPack m -> EntityDef -> m SingleMigration+migrateEntity :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> EntityDef -> m SingleMigration migrateEntity m@MigrationPack{..} e = do   let name = entityName e   let constrs = constructors e-  let mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ primaryKeyType ++ ", discr INTEGER NOT NULL)"-  let mainTableColumns = [Column "discr" False DbInt32 Nothing]+  let mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ primaryKeyTypeName ++ ", discr INTEGER NOT NULL)"+  let expectedMainStructure = TableInfo [Column "id" False primaryKeyType Nothing, Column "discr" False DbInt32 Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []    if isSimple constrs     then do-      x <- checkTable name+      x <- analyzeTable (entitySchema e) name       -- check whether the table was created for multiple constructors before       case x of-        Just (Right old) | haveSameElems (compareColumns m) (tableColumns old) mainTableColumns -> do+        Right (Just old) | null $ getAlters m old expectedMainStructure -> do           return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]-        Just (Left errs) -> return (Left errs)-        _ -> liftM snd $ migConstr m True name $ head constrs+        Right _ -> liftM snd $ migConstr m e $ head constrs+        Left errs -> return (Left errs)     else do-      maincolumns <- checkTable name+      mainStructure <- analyzeTable (entitySchema e) name       let constrTable c = name ++ [delim] ++ constrName c-      res <- mapM (\c -> migConstr m False name c) constrs-      case maincolumns of-        Nothing -> do+      res <- mapM (migConstr m e) constrs+      case mainStructure of+        Right Nothing -> do           -- no constructor tables can exist if there is no main data table           let orphans = filter (fst . fst) $ zip res constrs           return $ if null orphans             then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)]:map snd res             else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans-        Just (Right (TableInfo (Just _) columns [] [])) -> do-          if haveSameElems (compareColumns m) columns mainTableColumns+        Right (Just mainStructure') -> do+          if null $ getAlters m mainStructure' expectedMainStructure             then do               -- the datatype had also many constructors before               -- check whether any new constructors appeared and increment older discriminators, which were shifted by newer constructors inserted not in the end@@ -184,126 +197,139 @@                   go acc ((True, n):xs) = go (acc + n) xs                   go _ _ = []               return $ mergeMigrations $ updateDiscriminators: (map snd res)-            else do-              return $ Left ["Migration from one constructor to many will be implemented soon. Datatype: " ++ name]-        Just (Right structure) -> do-          return $ Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show structure]-        Just (Left errs) -> return (Left errs)+            else return $ Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure']+        Left errs -> return (Left errs) -migrateList :: Monad m => MigrationPack m -> DbType -> m SingleMigration+migrateList :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> DbType -> m SingleMigration migrateList m@MigrationPack{..} (DbList mainName t) = do   let valuesName = mainName ++ delim : "values"-  let (valueCols, valueRefs) = mkColumns id "value" t-  let mainQuery = "CREATE TABLE " ++ escape mainName ++ " (id " ++ primaryKeyType ++ ")"-  let (addInCreate, addInAlters) = addUniquesReferences [] valueRefs-  let items = ("id " ++ foreignKeyType ++ " NOT NULL REFERENCES " ++ escape mainName ++ " ON DELETE CASCADE"):"ord INTEGER NOT NULL" : map showColumn valueCols ++ addInCreate-  let valuesQuery = "CREATE TABLE " ++ escape valuesName ++ " (" ++ intercalate ", " items ++ ")"-  let expectedMainStructure = TableInfo (Just "id") [] [] []-  let valueColumns = Column "id" False DbInt64 Nothing : Column "ord" False DbInt32 Nothing : valueCols-  let expectedValuesStructure = TableInfo Nothing valueColumns [] (map (\x -> (Nothing, x)) $ (mainName, [("id", "id")]) : valueRefs)-  mainStructure <- checkTable mainName-  valuesStructure <- checkTable valuesName+      (valueCols, valueRefs) = mkColumns "value" t+      refs' = Reference Nothing mainName [("id", "id")] (Just Cascade) Nothing : valueRefs+      mainQuery = "CREATE TABLE " ++ escape mainName ++ " (id " ++ primaryKeyTypeName ++ ")"+      (addInCreate, addInAlters) = addUniquesReferences [] refs'+      items = ("id " ++ foreignKeyTypeName ++ " NOT NULL"):"ord INTEGER NOT NULL" : map showColumn valueCols ++ addInCreate+      valuesQuery = "CREATE TABLE " ++ escape valuesName ++ " (" ++ intercalate ", " items ++ ")"+      expectedMainStructure = TableInfo [Column "id" False primaryKeyType Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []+      valueColumns = Column "id" False primaryKeyType Nothing : Column "ord" False DbInt32 Nothing : valueCols+      expectedValuesStructure = TableInfo valueColumns [] (map (\x -> (Nothing, x)) refs')+  -- TODO: handle case when outer entity has a schema+  mainStructure <- analyzeTable Nothing mainName+  valuesStructure <- analyzeTable Nothing valuesName   let triggerMain = []-  (_, triggerValues) <- migTriggerOnDelete valuesName $ mkDeletes m valueCols+  (_, triggerValues) <- migTriggerOnDelete Nothing valuesName $ mkDeletes m valueCols   return $ case (mainStructure, valuesStructure) of-    (Nothing, Nothing) -> let-      rest = [AlterTable valuesName valuesQuery expectedValuesStructure expectedValuesStructure addInAlters]+    (Right Nothing, Right Nothing) -> let+      rest = [AlterTable Nothing valuesName valuesQuery expectedValuesStructure expectedValuesStructure addInAlters]       in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues-    (Just (Right mainStructure'), Just (Right valuesStructure')) -> let-      f name a@(TableInfo id1 cols1 uniqs1 refs1) b@(TableInfo id2 cols2 uniqs2 refs2) = if id1 == id2 && haveSameElems (compareColumns m) cols1 cols2 && haveSameElems compareUniqs uniqs1 uniqs2 && haveSameElems compareRefs refs1 refs2+    (Right (Just mainStructure'), Right (Just valuesStructure')) -> let+      f name a b = if null $ getAlters m a b         then []         else ["List table " ++ name ++ " error. Expected: " ++ show b ++ ". Found: " ++ show a]       errors = f mainName mainStructure' expectedMainStructure ++ f valuesName valuesStructure' expectedValuesStructure       in if null errors then Right [] else Left errors-    (Just (Left errs1), Just (Left errs2)) -> Left $ errs1 ++ errs2-    (Just (Left errs), Just _) -> Left errs-    (Just _, Just (Left errs)) -> Left errs-    (_, Nothing) -> Left ["Found orphan main list table " ++ mainName]-    (Nothing, _) -> Left ["Found orphan list values table " ++ valuesName]+    (Left errs1, Left errs2) -> Left $ errs1 ++ errs2+    (Left errs, Right _) -> Left errs+    (Right _, Left errs) -> Left errs+    (_, Right Nothing) -> Left ["Found orphan main list table " ++ mainName]+    (Right Nothing, _) -> Left ["Found orphan list values table " ++ valuesName] migrateList _ t = fail $ "migrateList: expected DbList, got " ++ show t --- from database, from datatype getAlters :: MigrationPack m-          -> TableInfo-          -> TableInfo+          -> TableInfo -- ^ From database+          -> TableInfo -- ^ From datatype           -> [AlterTable]-getAlters m@MigrationPack{..} (TableInfo oldId oldColumns oldUniques oldRefs) (TableInfo newId newColumns newUniques newRefs) = map AlterColumn colAlters ++ tableAlters+getAlters m@MigrationPack{..} (TableInfo oldColumns oldUniques oldRefs) (TableInfo newColumns newUniques newRefs) = tableAlters   where     (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements ((==) `on` colName) oldColumns newColumns     (oldOnlyUniques, newOnlyUniques, commonUniques) = matchElements compareUniqs oldUniques newUniques-    primaryKeyAlters = case (oldId, newId) of-      (Nothing, Just newName) -> [(newName, AddPrimaryKey)]-      (Just oldName, Nothing) -> [(oldName, Drop)]-      (Just oldName, Just newName) | oldName /= newName -> error $ "getAlters: cannot rename primary key (old " ++ oldName ++ ", new " ++ newName ++ ")"-      _ -> []     (oldOnlyRefs, newOnlyRefs, _) = matchElements compareRefs oldRefs newRefs+    primaryColumns = concatMap uniqueDefColumns $ filter ((== UniquePrimary) . uniqueDefType) oldUniques -    colAlters = map (\x -> (colName x, Drop)) oldOnlyColumns ++ map (\x -> (colName x, Add x)) newOnlyColumns ++ concatMap (migrateColumn m) commonColumns ++ primaryKeyAlters+    colAlters = mapMaybe (\(a, b) -> mkAlterColumn b $ migrateColumn m a b) (filter ((`notElem` primaryColumns) . colName . fst) commonColumns)+    mkAlterColumn col alters = if null alters then Nothing else Just $ AlterColumn col alters     tableAlters = -         map (\(UniqueDef' name typ _) -> case typ of UniqueConstraint -> DropConstraint name; UniqueIndex -> DropIndex name) oldOnlyUniques+         map (DropColumn . colName) oldOnlyColumns+      ++ map AddColumn newOnlyColumns+      ++ colAlters+      ++ map dropUnique oldOnlyUniques       ++ map AddUnique newOnlyUniques-      ++ concatMap migrateUniq commonUniques+      ++ concatMap (uncurry migrateUniq) commonUniques       ++ map (DropReference . fromMaybe (error "getAlters: old reference does not have name") . fst) oldOnlyRefs       ++ map (AddReference . snd) newOnlyRefs  -- from database, from datatype-migrateColumn :: MigrationPack m -> (Column, Column) -> [AlterColumn']-migrateColumn MigrationPack{..} (Column name1 isNull1 type1 def1, Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType where+migrateColumn :: MigrationPack m -> Column -> Column -> [AlterColumn]+migrateColumn MigrationPack{..} (Column _ isNull1 type1 def1) (Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType where   modNull = case (isNull1, isNull2) of-    (False, True) -> [(name1, IsNull)]+    (False, True) -> [IsNull]     (True, False) -> case def2 of-      Nothing -> [(name1, NotNull)]-      Just s -> [(name1, UpdateValue s), (name1, NotNull)]+      Nothing -> [NotNull]+      Just s -> [UpdateValue s, NotNull]     _ -> []-  modType = if compareTypes type1 type2 then [] else [(name1, Type type2)]+  modType = if compareTypes type1 type2 then [] else [Type type2]   modDef = if def1 == def2     then []-    else [(name1, maybe NoDefault Default def2)]+    else [maybe NoDefault Default def2]  -- from database, from datatype-migrateUniq :: (UniqueDef', UniqueDef') -> [AlterTable]-migrateUniq (UniqueDef' name1 _ cols1, u2@(UniqueDef' _ typ2 cols2)) = if haveSameElems (==) cols1 cols2+migrateUniq :: UniqueDef' -> UniqueDef' -> [AlterTable]+migrateUniq u1@(UniqueDef' _ _ cols1) u2@(UniqueDef' _ _ cols2) = if haveSameElems (==) cols1 cols2   then []-  else [if typ2 == UniqueConstraint then DropConstraint name1 else DropIndex name1, AddUnique u2]+  else [dropUnique u1, AddUnique u2]++dropUnique :: UniqueDef' -> AlterTable+dropUnique (UniqueDef' name typ _) = (case typ of+  UniqueConstraint -> DropConstraint name'+  UniqueIndex -> DropIndex name'+  UniquePrimary -> DropConstraint name') where+  name' = fromMaybe (error $ "dropUnique: constraint which should be dropped does not have a name") name   -defaultMigConstr :: Monad m => MigrationPack m -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)-defaultMigConstr migPack@MigrationPack{..} simple name constr = do-  let cName = if simple then name else name ++ [delim] ++ constrName constr-  let mkColumns' xs = concat *** concat $ unzip $ map (uncurry $ mkColumns id) xs-  let (columns, refs) = mkColumns' $ constrParams constr-  tableStructure <- checkTable cName+defaultMigConstr :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> EntityDef -> ConstructorDef -> m (Bool, SingleMigration)+defaultMigConstr migPack@MigrationPack{..} e constr = do+  let simple = isSimple $ constructors e+      name = entityName e+      schema = entitySchema e+      cName = if simple then name else name ++ [delim] ++ constrName constr+      mkColumns' xs = concat *** concat $ unzip $ map (uncurry mkColumns) xs+      (columns, refs) = mkColumns' $ constrParams constr+  tableStructure <- analyzeTable schema cName   let dels = mkDeletes migPack columns-  (triggerExisted, delTrigger) <- migTriggerOnDelete cName dels-  updTriggers <- liftM concat $ mapM (liftM snd . uncurry (migTriggerOnUpdate cName)) dels+  (triggerExisted, delTrigger) <- migTriggerOnDelete schema cName dels+  updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate schema cName dels   -  let mainTableName = if simple then Nothing else Just name-      refs' = maybeToList (fmap (\x -> (x, [(fromJust $ constrAutoKeyName constr, mainTableId)])) mainTableName) ++ refs+  let (mainRef, columns', refs', uniques') = case constrAutoKeyName constr of+        Nothing -> (primaryKeyTypeName, columns, refs, uniques)+        Just keyName | simple -> (primaryKeyTypeName, Column keyName False primaryKeyType Nothing:columns, refs, uniques ++ [UniqueDef' Nothing UniquePrimary [keyName]])+                     | otherwise -> (foreignKeyTypeName ++ " NOT NULL UNIQUE "+                      , Column (fromJust $ constrAutoKeyName constr) False primaryKeyType Nothing:columns+                      , refs ++ [Reference schema name [(fromJust $ constrAutoKeyName constr, mainTableId)] (Just Cascade) Nothing]+                      , uniques ++ [UniqueDef' Nothing UniqueConstraint [fromJust $ constrAutoKeyName constr]]+                      ) -      mainRef = maybe "" (\x -> " REFERENCES " ++ escape x ++ " ON DELETE CASCADE ") mainTableName-      autoKey = fmap (\x -> escape x ++ " " ++ primaryKeyType ++ mainRef) $ constrAutoKeyName constr+      uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' (Just uName) uType (map colName $ fst $ mkColumns' cols)) $ constrUniques constr -      uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' uName uType (map colName $ fst $ mkColumns' cols)) $ constrUniques constr-      (addInCreate, addInAlters) = addUniquesReferences uniques refs-      -- refs instead of refs' because the reference to the main table id is hardcoded in mainRef+      (addInCreate, addInAlters) = addUniquesReferences uniques refs'+      autoKey = fmap (\x -> escape x ++ " " ++ mainRef) $ constrAutoKeyName constr       items = maybeToList autoKey ++ map showColumn columns ++ addInCreate-      addTable = "CREATE TABLE " ++ escape cName ++ " (" ++ intercalate ", " items ++ ")"+      addTable = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")" -      expectedTableStructure = TableInfo (constrAutoKeyName constr) columns uniques (map (\r -> (Nothing, r)) refs')+-- change primary key and columns depending on isSimple+      expectedTableStructure = TableInfo columns' uniques' (map (\r -> (Nothing, r)) refs')       (migErrs, constrExisted, mig) = case tableStructure of-        Nothing  -> let-          rest = AlterTable cName addTable expectedTableStructure expectedTableStructure addInAlters+        Right Nothing  -> let+          rest = AlterTable schema cName addTable expectedTableStructure expectedTableStructure addInAlters           in ([], False, [AddTable addTable, rest])-        Just (Right oldTableStructure) -> let+        Right (Just oldTableStructure) -> let           alters = getAlters migPack oldTableStructure expectedTableStructure-          in ([], True, [AlterTable cName addTable oldTableStructure expectedTableStructure alters])-        Just (Left x) -> (x, True, [])+          in ([], True, [AlterTable schema cName addTable oldTableStructure expectedTableStructure alters])+        Left errs -> (errs, True, [])       -- this can happen when an ephemeral field was added. Consider doing something else except throwing an error-      errs = if constrExisted == triggerExisted || (constrExisted && null dels)+      allErrs = if constrExisted == triggerExisted || (constrExisted && null dels)         then migErrs         else ["Both trigger and constructor table must exist: " ++ cName] ++ migErrs-  return $ (constrExisted, if null errs+  return $ (constrExisted, if null allErrs     then mergeMigrations $ map showAlterDb $ mig ++ delTrigger ++ updTriggers-    else Left errs)+    else Left allErrs)  -- on delete removes all ephemeral data -- returns column name and delete statement for the referenced table@@ -315,6 +341,34 @@   ephemeralName (DbList name _) = Just name   ephemeralName _ = Nothing -compareColumns :: MigrationPack m -> Column -> Column -> Bool-compareColumns MigrationPack{..} (Column name1 isNull1 type1 def1) (Column name2 isNull2 type2 def2) =-  name1 == name2 && isNull1 == isNull2 && compareTypes type1 type2 && def1 == def2+showReferenceAction :: ReferenceActionType -> String+showReferenceAction NoAction = "NO ACTION"+showReferenceAction Restrict = "RESTRICT"+showReferenceAction Cascade = "CASCADE"+showReferenceAction SetNull = "SET NULL"+showReferenceAction SetDefault = "SET DEFAULT"++readReferenceAction :: String -> Maybe ReferenceActionType+readReferenceAction c = case c of+  "NO ACTION" -> Just NoAction+  "RESTRICT" -> Just Restrict+  "CASCADE" -> Just Cascade+  "SET NULL" -> Just SetNull+  "SET DEFAULT" -> Just SetDefault+  _ -> Nothing++class SchemaAnalyzer m where+  listTables :: Maybe String -- ^ Schema name+             -> m [String]+  listTableTriggers :: Maybe String -- ^ Schema name+                    -> String -- ^ Table name+                    -> m [String]+  analyzeTable :: Maybe String -- ^ Schema name+               -> String -- ^ Table name+               -> m (Either [String] (Maybe TableInfo))+  analyzeTrigger :: Maybe String -- ^ Schema name+                 -> String -- ^ Trigger name+                 -> m (Maybe String)+  analyzeFunction :: Maybe String -- ^ Schema name+                  -> String -- ^ Function name+                  -> m (Maybe String)

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, RecordWildCards, Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, OverloadedStrings, RecordWildCards, Rank2Types, TypeFamilies #-}  -- | This helper module contains generic versions of PersistBackend functions module Database.Groundhog.Generic.PersistBackendHelpers@@ -29,32 +29,30 @@ import Data.Monoid  {-# INLINABLE get #-}-get :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-    => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v)+get :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))+    => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v BackendSpecific -> m (Maybe v) get escape queryFunc (k :: Key v BackendSpecific) = do   let e = entityDef (undefined :: v)   let proxy = undefined :: Proxy (PhantomDb m)-  let name = persistName (undefined :: v)   if isSimple (constructors e)     then do       let constr = head $ constructors e       let fields = renderFields escape (constrParams constr)-      let query = "SELECT " <> fields <> " FROM " <> escape (fromString name) <> " WHERE " <> fromJust (constrId escape constr) <> "=?"+      let query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> " WHERE " <> fromJust (constrId escape constr) <> "=?"       let types = getConstructorTypes constr       x <- queryFunc query types [toPrimitivePersistValue proxy k] id       case x of         Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs         Nothing -> return Nothing     else do-      let query = "SELECT discr FROM " <> escape (fromString name) <> " WHERE id=?"+      let query = "SELECT discr FROM " <> mainTableName escape e <> " WHERE id=?"       x <- queryFunc query [DbInt32] [toPrimitivePersistValue proxy k] id       case x of         Just [discr] -> do           let constructorNum = fromPrimitivePersistValue proxy discr           let constr = constructors e !! constructorNum-          let cName = fromString $ name ++ [delim] ++ constrName constr           let fields = renderFields escape (constrParams constr)-          let cQuery = "SELECT " <> fields <> " FROM " <> escape cName <> " WHERE " <> fromJust (constrId escape constr) <> "=?"+          let cQuery = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> " WHERE " <> fromJust (constrId escape constr) <> "=?"           x2 <- queryFunc cQuery (getConstructorTypes constr) [toPrimitivePersistValue proxy k] id           case x2 of             Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ discr:xs@@ -62,20 +60,14 @@         Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'         Nothing -> return Nothing -select :: forall m s v c opts . (PersistBackend m, StringLike s, PersistEntity v, Constructor c, HasSelectOptions opts v c)-       => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> s -> (Cond v c -> Maybe (RenderS s)) -> opts -> m [v]-select escape queryFunc noLimit renderCond' options = start where+select :: forall m db r v c opts . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c, HasSelectOptions opts db r)+       => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> (Cond db r -> Maybe (RenderS db r)) -> opts -> m [v]+select escape queryFunc noLimit renderCond' options = doSelectQuery where   SelectOptions cond limit offset ords = getSelectOptions options-  start = if isSimple (constructors e)-    then doSelectQuery (mkQuery name) (0 :: Int)-    else let-      cName = name ++ [delim] ++ constrName constr-      in doSelectQuery (mkQuery cName) $ constrNum constr    e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)   orders = renderOrders escape ords-  name = persistName (undefined :: v)   (lim, limps) = case (limit, offset) of         (Nothing, Nothing) -> ("", [])         (Nothing, o) -> (" " <> noLimit <> " OFFSET ?", [toPrimitivePersistValue proxy o])@@ -83,90 +75,82 @@         (l, o) -> (" LIMIT ? OFFSET ?", [toPrimitivePersistValue proxy l, toPrimitivePersistValue proxy o])   cond' = renderCond' cond   fields = renderFields escape (constrParams constr)-  mkQuery tname = "SELECT " <> fields <> " FROM " <> escape (fromString tname) <> whereClause <> orders <> lim+  query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> whereClause <> orders <> lim   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'-  doSelectQuery query cNum = queryFunc query types binds $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)+  doSelectQuery = queryFunc query types binds $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)   binds = maybe id getValues cond' $ limps-  constr = constructors e !! phantomConstrNum (undefined :: c a)+  cNum = phantomConstrNum (undefined :: c a)+  constr = constructors e !! cNum   types = getConstructorTypes constr -selectAll :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v)-          => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)]+selectAll :: forall m v . (PersistBackend m, PersistEntity v)+          => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> m [(AutoKey v, v)] selectAll escape queryFunc = start where   start = if isSimple (constructors e)     then let       constr = head $ constructors e       fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId escape constr) $ renderFields escape (constrParams constr)-      query = "SELECT " <> fields <> " FROM " <> escape (fromString name)+      query = "SELECT " <> fields <> " FROM " <> tableName escape e constr       types = maybe id (const $ (DbInt64:)) (constrId escape constr) $ getConstructorTypes constr       in queryFunc query types [] $ mapAllRows $ mkEntity proxy 0     else liftM concat $ forM (zip [0..] (constructors e)) $ \(cNum, constr) -> do         let fields = fromJust (constrId escape constr) <> fromChar ',' <> renderFields escape (constrParams constr)-        let cName = fromString $ name ++ [delim] ++ constrName constr-        let query = "SELECT " <> fields <> " FROM " <> escape cName+        let query = "SELECT " <> fields <> " FROM " <> tableName escape e constr         let types = DbInt64:getConstructorTypes constr         queryFunc query types [] $ mapAllRows $ mkEntity proxy cNum   e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)-  name = persistName (undefined :: v) -getBy :: forall m s v u . (PersistBackend m, StringLike s, PersistEntity v, IsUniqueKey (Key v (Unique u)))-      => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v (Unique u) -> m (Maybe v)+getBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))+      => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Key v (Unique u) -> m (Maybe v) getBy escape queryFunc (k :: Key v (Unique u)) = do-  let e = entityDef (undefined :: v)-  let name = persistName (undefined :: v)   uniques <- toPersistValues k-  let u = (undefined :: Key v (Unique u) -> u (UniqueMarker v)) k-  let uFields = foldr (renderChain escape) [] $ projectionFieldChains u []-  let cond = intercalateS " AND " $ map (<> "=?") uFields-  let constr = head $ constructors e-  let fields = renderFields escape (constrParams constr)-  let query = "SELECT " <> fields <> " FROM " <> escape (fromString name) <> " WHERE " <> cond+  let e = entityDef (undefined :: v)+      u = (undefined :: Key v (Unique u) -> u (UniqueMarker v)) k+      uFields = (renderChain escape $ fieldChain u) []+      cond = intercalateS " AND " $ map (<> "=?") uFields+      constr = head $ constructors e+      fields = renderFields escape (constrParams constr)+      query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> " WHERE " <> cond   x <- queryFunc query (getConstructorTypes constr) (uniques []) id   case x of     Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs     Nothing -> return Nothing -project :: forall m s v c p opts a'. (PersistBackend m, StringLike s, PersistEntity v, Constructor c, Projection p (RestrictionHolder v c) a', HasSelectOptions opts v c)-        => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> s -> (Cond v c -> Maybe (RenderS s)) -> p -> opts -> m [a']-project escape queryFunc noLimit renderCond' p options = start where+project :: forall m db r v c p opts a'. (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c, Projection p db r a', HasSelectOptions opts db r)+        => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> Utf8 -> (Cond db r -> Maybe (RenderS db r)) -> p -> opts -> m [a']+project escape queryFunc noLimit renderCond' p options = doSelectQuery where   SelectOptions cond limit offset ords = getSelectOptions options-  start = doSelectQuery $ if isSimple (constructors e)-    then mkQuery name-    else let-      cName = name ++ [delim] ++ constrName constr-      in mkQuery cName-   e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)   orders = renderOrders escape ords-  name = persistName (undefined :: v)   (lim, limps) = case (limit, offset) of         (Nothing, Nothing) -> ("", [])         (Nothing, o) -> (" " <> noLimit <> " OFFSET ?", [toPrimitivePersistValue proxy o])         (l, Nothing) -> (" LIMIT ?", [toPrimitivePersistValue proxy l])         (l, o) -> (" LIMIT ? OFFSET ?", [toPrimitivePersistValue proxy l, toPrimitivePersistValue proxy o])   cond' = renderCond' cond-  chains = projectionFieldChains p []-  fields = intercalateS (fromChar ',') $ foldr (renderChain escape) [] chains-  mkQuery tname = "SELECT " <> fields <> " FROM " <> escape (fromString tname) <> whereClause <> orders <> lim+  chains = projectionExprs p []+--  fields = intercalateS (fromChar ',') $ foldr (renderChain escape) [] chains+  RenderS fields fieldVals  = intercalateS (fromChar ',') $ concatMap (renderExprExtended escape 0) chains+  query = "SELECT " <> fields <> " FROM " <> tableName escape e constr <> whereClause <> orders <> lim   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'-  doSelectQuery query = queryFunc query types binds $ mapAllRows $ liftM fst . projectionResult p-  binds = maybe id getValues cond' $ limps+  doSelectQuery = queryFunc query types binds $ mapAllRows $ liftM fst . projectionResult p+  binds = fieldVals . maybe id getValues cond' $ limps   constr = constructors e !! phantomConstrNum (undefined :: c a)-  types = foldr getDbTypes [] $ map (snd . fst) chains+  types = foldr (getDbTypes . exprType) [] $ chains where+    exprType (ExprRaw a) = dbType $ (undefined :: Expr db r a -> a) a+    exprType (ExprField ((_, t), _)) = t+    exprType (ExprPure a) = dbType a -count :: forall m s v c . (PersistBackend m, StringLike s, PersistEntity v, Constructor c)-      => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Cond v c -> Maybe (RenderS s)) -> Cond v c -> m Int-count escape queryFunc renderCond' (cond :: Cond v c) = do+count :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c)+      => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Cond db r -> Maybe (RenderS db r)) -> Cond db r -> m Int+count escape queryFunc renderCond' cond = do   let e = entityDef (undefined :: v)-  let proxy = undefined :: Proxy (PhantomDb m)-  let cond' = renderCond' cond-  let name = persistName (undefined :: v)-  let tname = fromString $ if isSimple (constructors e)-       then name-       else name ++ [delim] ++ phantomConstrName (undefined :: c a)-  let query = "SELECT COUNT(*) FROM " <> escape tname <> whereClause where+      proxy = undefined :: Proxy (PhantomDb m)+      cond' = renderCond' cond+      constr = constructors e !! phantomConstrNum (undefined :: c a)+      query = "SELECT COUNT(*) FROM " <> tableName escape e constr <> whereClause where       whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'   x <- queryFunc query [DbInt32] (maybe [] (flip getValues []) cond') id   case x of@@ -174,143 +158,128 @@     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)     Nothing -> fail $ "COUNT returned no rows" -replace :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-        => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (s -> [PersistValue] -> m ()) -> (Bool -> String -> ConstructorDef -> s)+replace :: forall m db r v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))+        => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> (Utf8 -> [PersistValue] -> m ()) -> (Bool -> Utf8 -> ConstructorDef -> [PersistValue] -> RenderS db r)         -> Key v BackendSpecific -> v -> m () replace escape queryFunc execFunc insertIntoConstructorTable k v = do   vals <- toEntityPersistValues' v   let e = entityDef v-  let proxy = undefined :: Proxy (PhantomDb m)-  let name = persistName v-  let constructorNum = fromPrimitivePersistValue proxy (head vals)-  let constr = constructors e !! constructorNum+      proxy = undefined :: Proxy (PhantomDb m)+      constructorNum = fromPrimitivePersistValue proxy (head vals)+      constr = constructors e !! constructorNum -  let upds = renderFields (\f -> escape f <> "=?") $ constrParams constr-  let mkQuery tname = "UPDATE " <> escape (fromString tname) <> " SET " <> upds <> " WHERE " <> fromString (fromJust $ constrAutoKeyName constr) <> "=?"+      upds = renderFields (\f -> escape f <> "=?") $ constrParams constr+      updateQuery = "UPDATE " <> tableName escape e constr <> " SET " <> upds <> " WHERE " <> fromString (fromJust $ constrAutoKeyName constr) <> "=?"    if isSimple (constructors e)-    then execFunc (mkQuery name) (tail vals ++ [toPrimitivePersistValue proxy k])+    then execFunc updateQuery (tail vals ++ [toPrimitivePersistValue proxy k])     else do-      let query = "SELECT discr FROM " <> escape (fromString name) <> " WHERE id=?"+      let query = "SELECT discr FROM " <> mainTableName escape e <> " WHERE id=?"       x <- queryFunc query [DbInt32] [toPrimitivePersistValue proxy k] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))       case x of         Just discr -> do-          let cName = name ++ [delim] ++ constrName constr+          let cName = tableName escape e constr            if discr == constructorNum-            then execFunc (mkQuery cName) (tail vals ++ [toPrimitivePersistValue proxy k])+            then execFunc updateQuery (tail vals ++ [toPrimitivePersistValue proxy k])             else do-              let insQuery = insertIntoConstructorTable True cName constr-              execFunc insQuery (toPrimitivePersistValue proxy k:tail vals)+              let RenderS insQuery vals' = insertIntoConstructorTable True cName constr (toPrimitivePersistValue proxy k:tail vals)+              execFunc insQuery (vals' []) -              let oldCName = fromString $ name ++ [delim] ++ constrName (constructors e !! discr)-              let delQuery = "DELETE FROM " <> escape oldCName <> " WHERE " <> fromJust (constrId escape constr) <> "=?"+              let oldConstr = constructors e !! discr+              let delQuery = "DELETE FROM " <> tableName escape e oldConstr <> " WHERE " <> fromJust (constrId escape oldConstr) <> "=?"               execFunc delQuery [toPrimitivePersistValue proxy k] -              let updateDiscrQuery = "UPDATE " <> escape (fromString name) <> " SET discr=? WHERE id=?"+              let updateDiscrQuery = "UPDATE " <> mainTableName escape e <> " SET discr=? WHERE id=?"               execFunc updateDiscrQuery [head vals, toPrimitivePersistValue proxy k]         Nothing -> return () -update :: forall m s v c . (PersistBackend m, StringLike s, PersistEntity v, Constructor c)-       => (s -> s) -> (s -> [PersistValue] -> m ()) -> (Cond v c -> Maybe (RenderS s)) -> [Update v c] -> Cond v c -> m ()-update escape execFunc renderCond' upds (cond :: Cond v c) = do+update :: forall m db r v c . (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c)+       => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> (Cond db r -> Maybe (RenderS db r)) -> [Update db r] -> Cond db r -> m ()+update escape execFunc renderCond' upds cond = do   let e = entityDef (undefined :: v)-  let proxy = undefined :: Proxy (PhantomDb m)-  let name = persistName (undefined :: v)-  case renderUpdates proxy escape upds of+  case renderUpdates escape upds of     Just upds' -> do       let cond' = renderCond' cond-      let mkQuery tname = "UPDATE " <> escape tname <> " SET " <> whereClause where+          constr = constructors e !! phantomConstrNum (undefined :: c a)+          query = "UPDATE " <> tableName escape e constr <> " SET " <> whereClause where           whereClause = maybe (getQuery upds') (\c -> getQuery upds' <> " WHERE " <> getQuery c) cond'-      let tname = fromString $ if isSimple (constructors e) then name else name ++ [delim] ++ phantomConstrName (undefined :: c a)-      execFunc (mkQuery tname) (getValues upds' <> maybe mempty getValues cond' $ [])+      execFunc query (getValues upds' <> maybe mempty getValues cond' $ [])     Nothing -> return () -delete :: forall m s v c . (PersistBackend m, StringLike s, PersistEntity v, Constructor c)-       => (s -> s) -> (s -> [PersistValue] -> m ()) -> (Cond v c -> Maybe (RenderS s)) -> Cond v c -> m ()-delete escape execFunc renderCond' (cond :: Cond v c) = execFunc query (maybe [] (($ []) . getValues) cond') where+delete :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c)+       => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> (Cond db r -> Maybe (RenderS db r)) -> Cond db r -> m ()+delete escape execFunc renderCond' cond = execFunc query (maybe [] (($ []) . getValues) cond') where   e = entityDef (undefined :: v)-  constr = head $ constructors e+  constr = constructors e !! phantomConstrNum (undefined :: c a)   cond' = renderCond' cond-  name = persistName (undefined :: v)   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'   query = if isSimple (constructors e)-    then "DELETE FROM " <> escape (fromString name) <> whereClause+    then "DELETE FROM " <> tableName escape e constr <> whereClause     -- the entries in the constructor table are deleted because of the reference on delete cascade-    else "DELETE FROM " <> escape (fromString name) <> " WHERE id IN(SELECT " <> fromJust (constrId escape constr) <> " FROM " <> escape cName <> whereClause <> ")" where-      cName = fromString $ name ++ [delim] ++ phantomConstrName (undefined :: c a)+    else "DELETE FROM " <> mainTableName escape e <> " WHERE id IN(SELECT " <> fromJust (constrId escape constr) <> " FROM " <> tableName escape e constr <> whereClause <> ")" -insertByAll :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v)-            => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)+insertByAll :: forall m v . (PersistBackend m, PersistEntity v)+            => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)             -> v -> m (Either (AutoKey v) (AutoKey v)) insertByAll escape queryFunc v = do   let e = entityDef v-  let proxy = undefined :: Proxy (PhantomDb m)-  let name = persistName v--  let (constructorNum, uniques) = getUniques proxy v-  let uniqueDefs = constrUniques $ constructors e !! constructorNum-  let cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ _ fields) -> fields) uniqueDefs--  let ifAbsent tname constr = do-      let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> escape (fromString tname) <> " WHERE " <> cond+      proxy = undefined :: Proxy (PhantomDb m)+      (constructorNum, uniques) = getUniques proxy v+      constr = constructors e !! constructorNum+      uniqueDefs = constrUniques constr+      cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ _ fields) -> fields) uniqueDefs+  if null uniques+    then liftM Right $ Core.insert v+    else do+      let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> tableName escape e constr <> " WHERE " <> cond       x <- queryFunc query [DbInt64] (foldr ((.) . snd) id uniques []) id       case x of         Nothing  -> liftM Right $ Core.insert v         Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]         Just xs  -> fail $ "unexpected query result: " ++ show xs-  if null uniques-    then liftM Right $ Core.insert v-    else if isSimple (constructors e)-      then do-        let constr = head $ constructors e-        ifAbsent name constr-      else do-        let constr = constructors e !! constructorNum-        let cName = name ++ [delim] ++ constrName constr-        ifAbsent cName constr -deleteByKey :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))-            => (s -> s) -> (s -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m ()+deleteByKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))+            => (Utf8 -> Utf8) -> (Utf8 -> [PersistValue] -> m ()) -> Key v BackendSpecific -> m () deleteByKey escape execFunc k = execFunc query [toPrimitivePersistValue proxy k] where   e = entityDef ((undefined :: Key v u -> v) k)   proxy = undefined :: Proxy (PhantomDb m)   constr = head $ constructors e-  name = fromString (persistName $ (undefined :: Key v u -> v) k)-  query = "DELETE FROM " <> escape name <> " WHERE " <> fromJust (constrId escape constr) <> "=?"+  idName = if isSimple (constructors e)+    then fromJust $ constrId escape constr+    else "id"+  -- the entries in the constructor table are deleted because of the reference on delete cascade+  query = "DELETE FROM " <> mainTableName escape e <> " WHERE " <> idName <> "=?" -countAll :: forall m s v . (PersistBackend m, StringLike s, PersistEntity v)-         => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int+countAll :: forall m v . (PersistBackend m, PersistEntity v)+         => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a) -> v -> m Int countAll escape queryFunc (_ :: v) = do-  let proxy = undefined :: Proxy (PhantomDb m)-  let name = persistName (undefined :: v)-  let query = "SELECT COUNT(*) FROM " <> escape (fromString name)+  let e = entityDef (undefined :: v)+      proxy = undefined :: Proxy (PhantomDb m)+      query = "SELECT COUNT(*) FROM " <> mainTableName escape e   x <- queryFunc query [DbInt64] [] id   case x of     Just [num] -> return $ fromPrimitivePersistValue proxy num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)     Nothing -> fail $ "COUNT returned no rows" -insertBy :: forall m s v u . (PersistBackend m, StringLike s, PersistEntity v, IsUniqueKey (Key v (Unique u)))-         => (s -> s) -> (forall a . s -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)+insertBy :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)))+         => (Utf8 -> Utf8) -> (forall a . Utf8 -> [DbType] -> [PersistValue] -> (RowPopper m -> m a) -> m a)          -> u (UniqueMarker v) -> v -> m (Either (AutoKey v) (AutoKey v)) insertBy escape queryFunc u v = do-  let e = entityDef v-  let proxy = undefined :: Proxy (PhantomDb m)-  let name = persistName v   uniques <- toPersistValues $ (extractUnique v `asTypeOf` ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u))-  let fields = foldr (renderChain escape) [] $ projectionFieldChains u []-  let cond = intercalateS " AND " $ map (<> "=?") fields-  -  let ifAbsent tname constr = do-      let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> escape (fromString tname) <> " WHERE " <> cond-      x <- queryFunc query [DbInt64] (uniques []) id-      case x of-        Nothing  -> liftM Right $ Core.insert v-        Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]-        Just xs  -> fail $ "unexpected query result: " ++ show xs-  let constr = head $ constructors e-  ifAbsent name constr+  let e = entityDef v+      proxy = undefined :: Proxy (PhantomDb m)+      uFields = (renderChain escape $ fieldChain u) []+      cond = intercalateS " AND " $ map (<> "=?") uFields+      -- this is safe because unique keys exist only for entities with one constructor+      constr = head $ constructors e+      query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> tableName escape e constr <> " WHERE " <> cond+  x <- queryFunc query [DbInt64] (uniques []) id+  case x of+    Nothing  -> liftM Right $ Core.insert v+    Just [k] -> return $ Left $ fst $ fromPurePersistValues proxy [k]+    Just xs  -> fail $ "unexpected query result: " ++ show xs  getConstructorTypes :: ConstructorDef -> [DbType] getConstructorTypes = foldr getDbTypes [] . map snd . constrParams where@@ -318,10 +287,10 @@ getDbTypes :: DbType -> [DbType] -> [DbType] getDbTypes typ acc = case typ of   DbEmbedded (EmbeddedDef _ ts) -> foldr (getDbTypes . snd) acc ts-  DbEntity (Just (EmbeddedDef _ ts, _)) _ -> foldr (getDbTypes . snd) acc ts-  t               -> t:acc+  DbEntity (Just (EmbeddedDef _ ts, _)) _ _ _ -> foldr (getDbTypes . snd) acc ts+  t -> t:acc -constrId :: StringLike s => (s -> s) -> ConstructorDef -> Maybe s+constrId :: (Utf8 -> Utf8) -> ConstructorDef -> Maybe Utf8 constrId escape = fmap (escape . fromString) . constrAutoKeyName  -- | receives constructor number and row of values from the constructor table

@@ -1,124 +1,178 @@-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, GADTs, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, GADTs, OverloadedStrings, TypeSynonymInstances, FlexibleInstances, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | This module defines the functions which are used only for backends creation. module Database.Groundhog.Generic.Sql-    ( renderCond+    ( +    -- * SQL rendering utilities+      renderCond     , defaultShowPrim-    , renderArith     , renderOrders     , renderUpdates     , renderFields     , renderChain+    , renderExpr+    , renderExprPriority+    , renderExprExtended+    , renderPersistValue     , intercalateS+    , commasJoin     , RenderS(..)+    , Utf8(..)+    , fromUtf8     , StringLike(..)     , fromString     , (<>)+    , function+    , operator     , parens+    , Snippet(..)+    , SqlDb(..)+    , liftExpr+    , tableName+    , mainTableName     ) where  import Database.Groundhog.Core+import Database.Groundhog.Generic (isSimple) import Database.Groundhog.Instances ()-import Data.List (foldl')+import qualified Blaze.ByteString.Builder.Char.Utf8 as B+import Data.Int (Int64) import Data.Maybe (mapMaybe) import Data.Monoid import Data.String +import Database.Groundhog.Expression+ class (Monoid a, IsString a) => StringLike a where   fromChar :: Char -> a -data RenderS s = RenderS {-    getQuery  :: s+data RenderS db r = RenderS {+    getQuery  :: Utf8   , getValues :: [PersistValue] -> [PersistValue] } -instance Monoid s => Monoid (RenderS s) where+instance Monoid Utf8 where+  mempty = Utf8 mempty+  mappend (Utf8 a) (Utf8 b) = Utf8 (mappend a b)++instance IsString Utf8 where+  fromString = Utf8 . B.fromString++instance StringLike Utf8 where+  fromChar = Utf8 . B.fromChar++-- | Escape function, priority of the outer operator. The result is a list for the embedded data which may expand to several RenderS.+newtype Snippet db r = Snippet ((Utf8 -> Utf8) -> Int -> [RenderS db r])++-- Alas, GHC before 7.2 does not support superclass equality constraints (QueryRaw db ~ Snippet db).+-- | This class distinguishes databases which support SQL-specific expressions. It contains ad hoc members for features whose syntax differs across the databases.+class DbDescriptor db => SqlDb db where+  append :: (ExpressionOf db r a String, ExpressionOf db r b String) => a -> b -> Expr db r String++renderExpr :: (DbDescriptor db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> UntypedExpr db r -> RenderS db r+renderExpr esc expr = renderExprPriority esc 0 expr++renderExprPriority :: (DbDescriptor db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> Int -> UntypedExpr db r -> RenderS db r+renderExprPriority esc p expr = (case expr of+  ExprRaw (Expr (Snippet f)) -> let vals = f esc p in ensureOne vals id+  ExprField f -> let fs = renderChain esc f []+                 in ensureOne fs $ \f' -> RenderS f' id+  ExprPure  a -> let vals = toPurePersistValues proxy a+                 in ensureOne (vals []) renderPersistValue) where+    proxy = (undefined :: f db r -> Proxy db) expr+    ensureOne :: [a] -> (a -> b) -> b+    ensureOne xs f = case xs of+      [x] -> f x+      xs' -> error $ "renderExprPriority: expected one column field, found " ++ show (length xs')++renderExprExtended :: (DbDescriptor db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> Int -> UntypedExpr db r -> [RenderS db r]+renderExprExtended esc p expr = (case expr of+  ExprRaw (Expr (Snippet f)) -> f esc p+  ExprField f -> map (flip RenderS id) $ renderChain esc f []+  ExprPure a -> let vals = toPurePersistValues proxy a []+                in map renderPersistValue vals) where+  proxy = (undefined :: f db r -> Proxy db) expr++renderPersistValue :: PersistValue -> RenderS db r+renderPersistValue (PersistCustom s as) = RenderS s (as++)+renderPersistValue a = RenderS (fromChar '?') (a:)++instance Monoid (RenderS db r) where   mempty = RenderS mempty id   (RenderS f1 g1) `mappend` (RenderS f2 g2) = RenderS (f1 `mappend` f2) (g1 . g2) +instance IsString (RenderS db r) where+  fromString s = RenderS (fromString s) id++instance StringLike (RenderS db r) where+  fromChar c = RenderS (fromChar c) id+ -- Has bad performance. This instance exists only for testing purposes instance StringLike String where   fromChar c = [c]  {-# INLINABLE parens #-}-parens :: StringLike s => Int -> Int -> RenderS s -> RenderS s-parens p1 p2 expr = if p1 < p2 then char '(' <> expr <> char ')' else expr+parens :: Int -> Int -> RenderS db r -> RenderS db r+parens p1 p2 expr = if p1 < p2 then fromChar '(' <> expr <> fromChar ')' else expr +operator :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a, Expression db r b) => Int -> String -> a -> b -> Snippet db r+operator pr op = \a b -> Snippet $ \esc p ->+  [parens pr p $ renderExprPriority esc pr (toExpr a) <> fromString op <> renderExprPriority esc pr (toExpr b)]++function :: (SqlDb db, QueryRaw db ~ Snippet db) => String -> [UntypedExpr db r] -> Snippet db r+function func args = Snippet $ \esc _ -> [fromString func <> fromChar '(' <> commasJoin (map (renderExpr esc) args) <> fromChar ')']+ #if !MIN_VERSION_base(4, 5, 0) {-# INLINABLE (<>) #-} (<>) :: Monoid m => m -> m -> m (<>) = mappend #endif -string :: StringLike s => String -> RenderS s-string s = RenderS (fromString s) id--char :: StringLike s => Char -> RenderS s-char c = RenderS (fromChar c) id--{-# INLINABLE renderArith #-}-renderArith :: (PersistEntity v, Constructor c, StringLike s, DbDescriptor db) => Proxy db -> (s -> s) -> Arith v c a -> RenderS s-renderArith proxy escape arith = go arith 0 where-  go (Plus a b)     p = parens 6 p $ go a 6 <> char '+' <> go b 6-  go (Minus a b)    p = parens 6 p $ go a 6 <> char '-' <> go b 6-  go (Mult a b)     p = parens 7 p $ go a 7 <> char '*' <> go b 7-  go (Abs a)        p = parens 9 p $ string "ABS(" <> go a 0 <> char ')'-  go (ArithField f) _ = RenderS (head $ renderField escape f []) id-  go (Lit a)        _ = RenderS (fromChar '?') (toPurePersistValues proxy a)+instance (SqlDb db, QueryRaw db ~ Snippet db, PersistField a, Num a) => Num (Expr db r a) where+  a + b = Expr $ operator 60 "+" a b+  a - b = Expr $ operator 60 "-" a b+  a * b = Expr $ operator 70 "*" a b+  signum = error "Num Expr: no signum"+  abs a = Expr $ Snippet $ \esc _ -> ["ABS(" <> renderExpr esc (toExpr a) <> fromChar ')']+  fromInteger a = liftExpr' (fromIntegral a :: Int64)  {-# INLINABLE renderCond #-} -- | Renders conditions for SQL backend. Returns Nothing if the fields don't have any columns.-renderCond :: forall v c s db . (PersistEntity v, Constructor c, StringLike s, DbDescriptor db)-  => Proxy db-  -> (s -> s) -- escape-  -> (s -> s -> s) -- render equals-  -> (s -> s -> s) -- render not equals-  -> Cond v c -> Maybe (RenderS s)-renderCond proxy esc rendEq rendNotEq (cond :: Cond v c) = go cond 0 where-  go (And a b)       p = perhaps 3 p " AND " a b-  go (Or a b)        p = perhaps 2 p " OR " a b-  go (Not a)         p = fmap (\a' -> parens 1 p $ string "NOT " <> a') $ go a 1+renderCond :: forall r db . (SqlDb db, QueryRaw db ~ Snippet db)+  => (Utf8 -> Utf8) -- ^ escape+  -> (Utf8 -> Utf8 -> Utf8) -- ^ render equals+  -> (Utf8 -> Utf8 -> Utf8) -- ^ render not equals+  -> Cond db r -> Maybe (RenderS db r)+renderCond esc rendEq rendNotEq (cond :: Cond db r) = go cond 0 where+  go (And a b)       p = perhaps andP p " AND " a b+  go (Or a b)        p = perhaps orP p " OR " a b+  go (Not a)         p = fmap (\a' -> parens notP p $ "NOT " <> a') $ go a notP   go (Compare op f1 f2) p = case op of-    Eq -> renderComp 3 p " AND " rendEq f1 f2-    Ne -> renderComp 2 p " OR " rendNotEq f1 f2-    Gt -> renderComp 2 p " OR " (\a b -> a <> fromChar '>' <> b) f1 f2-    Lt -> renderComp 2 p " OR " (\a b -> a <> fromChar '<' <> b) f1 f2-    Ge -> renderComp 2 p " OR " (\a b -> a <> ">=" <> b) f1 f2-    Le -> renderComp 2 p " OR " (\a b -> a <> "<=" <> b) f1 f2+    Eq -> renderComp andP p " AND " rendEq f1 f2+    Ne -> renderComp orP p " OR " rendNotEq f1 f2+    Gt -> renderComp orP p " OR " (\a b -> a <> fromChar '>' <> b) f1 f2+    Lt -> renderComp orP p " OR " (\a b -> a <> fromChar '<' <> b) f1 f2+    Ge -> renderComp orP p " OR " (\a b -> a <> ">=" <> b) f1 f2+    Le -> renderComp orP p " OR " (\a b -> a <> "<=" <> b) f1 f2+  go (CondRaw (Snippet f)) p = case f esc p of+    [] -> Nothing+    [a] -> Just a+    _ -> error "renderCond: cannot render CondRaw with many elements"+  notP = 35+  andP = 30+  orP = 20 -  renderComp :: Int -> Int -> s -> (s -> s -> s) -> Expr v c a -> Expr v c b -> Maybe (RenderS s)-  renderComp p pOuter logicOp op expr1 expr2 = (case expr1 of-    ExprField field -> (case expr2 of-        ExprPure  a -> guard (map (\f -> f `op` fromChar '?') fs) (toPurePersistValues proxy a)-        ExprField a -> guard (zipWith op fs $ renderField esc a []) id-        ExprArith a -> case fs of-          [f] -> let RenderS q v = renderArith proxy esc a in Just $ RenderS (f `op` q) v-          _   -> error $ "renderComp: expected one column field, found " ++ show (length fs)) where-        fs = renderField esc field []-    ExprPure pure -> (case expr2 of-      ExprPure  a -> guard (replicate (length fs) $ fromChar '?' `op` fromChar '?') (interleave fs $ toPurePersistValues proxy a [])-      ExprField a -> guard (map (\f -> fromChar '?' `op` f) $ renderField esc a []) (toPurePersistValues proxy pure)-      ExprArith a -> case fs of-        [_] -> let RenderS q v = renderArith proxy esc a in Just $ RenderS (fromChar '?' `op` q) (toPurePersistValues proxy pure . v)-        _   -> error $ "renderComp: expected one column field, found " ++ show (length fs)) where-      fs = toPurePersistValues proxy pure []-    ExprArith arith -> (case expr2 of-      ExprPure  a -> Just $ RenderS (q `op` fromChar '?') (v . toPurePersistValues proxy a) -- TODO: check list size-      ExprField a -> Just $ RenderS (q `op` head (renderField esc a [])) v -- TODO: check list size-      ExprArith a -> let RenderS q2 v2 = renderArith proxy esc a in Just $ RenderS (q `op` q2) (v . v2)) where-        RenderS q v = renderArith proxy esc arith-      ) where-        guard :: [s] -> ([PersistValue] -> [PersistValue]) -> Maybe (RenderS s)-        guard clauses values = case clauses of-          [] -> Nothing-          [clause] -> Just $ RenderS clause values-          clauses' -> Just $ parens p pOuter $ RenderS (intercalateS logicOp clauses') values-        interleave [] [] acc = acc-        interleave (x:xs) (y:ys) acc = x:y:interleave xs ys acc-        interleave _ _ _ = error "renderComp: pure values lists must have the same size"-  -  perhaps :: Int -> Int -> s -> Cond v c -> Cond v c -> Maybe (RenderS s)+  renderComp p pOuter logicOp op expr1 expr2 = result where+    expr1' = renderExprExtended esc p' expr1+    expr2' = renderExprExtended esc p' expr2+    liftOp f (RenderS a1 b1) (RenderS a2 b2) = RenderS (f a1 a2) (b1 . b2)+    (result, p') = case zipWith (liftOp op) expr1' expr2' of+      [clause] -> (Just clause, pOuter)+      [] -> (Nothing, pOuter)+      clauses -> (Just $ parens p pOuter $ intercalateS logicOp clauses, p)+  perhaps :: Int -> Int -> Utf8 -> Cond db r -> Cond db r -> Maybe (RenderS db r)   perhaps p pOuter op a b = result where     -- we don't know if the current operator is present until we render both operands. Rendering requires priority of the outer operator. We tie a knot to defer calculating the priority     (priority, result) = case (go a priority, go b priority) of@@ -128,51 +182,6 @@        (Nothing, Nothing) -> (pOuter, Nothing)  {---- TODO: they don't support all cases-{-# INLINABLE defRenderEquals #-}-defRenderEquals :: (PersistField a, StringLike s) => (String -> String) -> Expr v c a -> Expr v c a -> RenderS s-defRenderEquals esc a b | not (isNullable a) = renderExpr esc a <> char '=' <> renderExpr esc b--- only ExprPrim and ExprField can come here here--- if one of arguments is Nothing, compare the other with NULL-defRenderEquals _ (ExprPure a) (ExprPure b) | isNull a && isNull b = string "NULL IS NULL"-defRenderEquals esc (ExprPure a) b | isNull a = renderExpr esc b <> string " IS NULL"-                                    | otherwise = renderPrim a <> char '=' <> renderExpr esc b-defRenderEquals esc a (ExprPure b) | isNull b = renderExpr esc a <> string " IS NULL"-                                    | otherwise = renderExpr esc a <> char '=' <> renderPrim b---  if both are fields we compare them to each other and to null-defRenderEquals esc (ExprField a) (ExprField b) = char '(' <> a' <> char '=' <> b' <> string " OR " <> a' <> string " IS NULL AND " <> b' <> string " IS NULL)" where-  a' = string $ esc (show a)-  b' = string $ esc (show b)-defRenderEquals _ _ _ = error "for nullable values there must be no other expressions than ExprField and ExprPure"--{-# INLINABLE defRenderNotEquals #-}-defRenderNotEquals :: (PersistField a, StringLike s) => (String -> String) -> Expr v c a -> Expr v c a -> RenderS s-defRenderNotEquals esc a b | not (isNullable a) = renderExpr esc a <> string "<>" <> renderExpr esc b--- if one of arguments is Nothing, compare the other with NULL-defRenderNotEquals _ (ExprPure a) (ExprPure b) | isNull a && isNull b = string "NULL IS NOT NULL"-defRenderNotEquals esc (ExprPure a) b | isNull a  = renderExpr esc b <> string " IS NOT NULL"-                                       | otherwise = char '(' <> renderPrim a <> string "<>" <> renderExpr esc b <> string " OR " <> renderExpr esc b <> string " IS NULL)"-defRenderNotEquals esc a (ExprPure b) | isNull b = renderExpr esc a <> string " IS NOT NULL"-                                       | otherwise = char '(' <> renderExpr esc a <> string "<>" <> renderPrim b <> string " OR " <> renderExpr esc a <> string " IS NULL)"-defRenderNotEquals esc (ExprField a) (ExprField b) = a' <> string "<>" <> b' <> string " OR (" <> a' <> string " IS NULL AND " <> b' <> string " IS NOT NULL) OR (" <> a' <> string " IS NOT NULL AND " <> b' <> string " IS NULL)" where-  a' = string $ esc (show a)-  b' = string $ esc (show b)-defRenderNotEquals _ _ _ = error "for nullable values there must be no other expressions than ExprField and ExprPure"--isNull :: Primitive a => a -> Bool-isNull a = toPrim a == PersistNull--isNullable :: PersistField a => Expr v c a -> Bool-isNullable (_ :: Expr v c a) = case dbType (undefined :: a) of-  DbMaybe _ -> True-  _         -> False---}--renderField :: (PersistEntity v, Constructor c, FieldLike f (RestrictionHolder v c) a', StringLike s) => (s -> s) -> f -> [s] -> [s]-renderField esc field acc = renderChain esc (fieldChain field) acc--{- examples of prefixes [("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> "val5$val4$val1" [("val1", DbEmbedded True _),  ("val4", EmbeddedDef False _), ("val5", EmbeddedDef False _)] -> ""@@ -181,7 +190,7 @@ [("val1", DbEmbedded False _), ("val4", EmbeddedDef False _), ("val5", EmbeddedDef True _)] -> "val4$val1" -} {-# INLINABLE renderChain #-}-renderChain :: StringLike s => (s -> s) -> FieldChain -> [s] -> [s]+renderChain :: (Utf8 -> Utf8) -> FieldChain -> [Utf8] -> [Utf8] renderChain esc (f, prefix) acc = (case prefix of   ((name, EmbeddedDef False _):fs) -> flattenP esc (goP (fromString name) fs) f acc   _ -> flatten esc f acc) where@@ -199,40 +208,41 @@ defaultShowPrim (PersistUTCTime x) = show x defaultShowPrim (PersistZonedTime x) = show x defaultShowPrim (PersistNull) = "NULL"+defaultShowPrim (PersistCustom _ _) = error "Unexpected PersistCustom"  {-# INLINABLE renderOrders #-}-renderOrders :: forall v c s . (PersistEntity v, Constructor c, StringLike s) => (s -> s) -> [Order v c] -> s+renderOrders :: forall db r . (Utf8 -> Utf8) -> [Order db r] -> Utf8 renderOrders _ [] = mempty renderOrders esc xs = if null orders then mempty else " ORDER BY " <> commasJoin orders where   orders = foldr go [] xs-  go (Asc a) acc = renderField esc a acc-  go (Desc a) acc = renderField (\f -> esc f <> " DESC") a acc+  go (Asc a) acc = renderChain esc (fieldChain a) acc+  go (Desc a) acc = renderChain (\f -> esc f <> " DESC") (fieldChain a) acc  {-# INLINABLE renderFields #-} -- Returns string with comma separated escaped fields like "name,age" -- If there are other columns before renderFields result, do not put comma because the result might be an empty string. This happens when the fields have no columns like ().--- One of the solutions is to add one more field with datatype that is known to have columns, eg renderFields id (("id$", namedType (0 :: Int64)) : constrParams constr)-renderFields :: StringLike s => (s -> s) -> [(String, DbType)] -> s+-- One of the solutions is to add one more field with datatype that is known to have columns, eg renderFields id (("id", namedType (0 :: Int64)) : constrParams constr)+renderFields :: (Utf8 -> Utf8) -> [(String, DbType)] -> Utf8 renderFields esc = commasJoin . foldr (flatten esc) []  -- TODO: merge code of flatten and flattenP-flatten :: StringLike s => (s -> s) -> (String, DbType) -> ([s] -> [s])+flatten :: (Utf8 -> Utf8) -> (String, DbType) -> ([Utf8] -> [Utf8]) flatten esc (fname, typ) acc = go typ where   go typ' = case typ' of     DbMaybe t -> go t     DbEmbedded emb -> handleEmb emb-    DbEntity (Just (emb, _)) _ -> handleEmb emb+    DbEntity (Just (emb, _)) _ _ _ -> handleEmb emb     _            -> esc fullName : acc   fullName = fromString fname   handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts   handleEmb (EmbeddedDef True  ts) = foldr (flatten esc) acc ts -flattenP :: StringLike s => (s -> s) -> s -> (String, DbType) -> ([s] -> [s])+flattenP :: (Utf8 -> Utf8) -> Utf8 -> (String, DbType) -> ([Utf8] -> [Utf8]) flattenP esc prefix (fname, typ) acc = go typ where   go typ' = case typ' of     DbMaybe t -> go t     DbEmbedded emb -> handleEmb emb-    DbEntity (Just (emb, _)) _ -> handleEmb emb+    DbEntity (Just (emb, _)) _ _ _ -> handleEmb emb     _            -> esc fullName : acc   fullName = prefix <> fromChar delim <> fromString fname   handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts@@ -248,20 +258,36 @@   go [] = mempty   go (f:fs) = a <> f <> go fs -commasJoinRenders :: StringLike s => [RenderS s] -> Maybe (RenderS s)-commasJoinRenders [] = Nothing-commasJoinRenders (x:xs) = Just $ foldl' f x xs where-  f (RenderS str1 vals1) (RenderS str2 vals2) = RenderS (str1 <> comma <> str2) (vals1 <> vals2)-  comma = fromChar ','- {-# INLINABLE renderUpdates #-}-renderUpdates :: (PersistEntity v, Constructor c, StringLike s, DbDescriptor db) => Proxy db -> (s -> s) -> [Update v c] -> Maybe (RenderS s)-renderUpdates p esc = commasJoinRenders . mapMaybe go where-  go (Update field expr) = (case expr of-      ExprPure  a -> guard $ RenderS (commasJoin $ map (\f -> f <> "=?") fs) (toPurePersistValues p a)-      ExprField a -> guard $ RenderS (commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs $ renderField esc a []) id-      ExprArith a -> case fs of-        [f] -> Just $ RenderS (f <> fromChar '=') id <> renderArith p esc a-        _   -> error $ "renderUpdates: expected one column field, found " ++ show (length fs)) where-      guard a = if null fs then Nothing else Just a-      fs = renderField esc field []+renderUpdates :: (SqlDb db, QueryRaw db ~ Snippet db) => (Utf8 -> Utf8) -> [Update db r] -> Maybe (RenderS db r)+renderUpdates esc upds = (case mapMaybe go upds of+  [] -> Nothing+  xs -> Just $ commasJoin xs) where+  go (Update field expr) = guard $ commasJoin $ zipWith (\f1 f2 -> f1 <> fromChar '=' <> f2) fs (rend expr) where+    rend = renderExprExtended esc 0+    fs = concatMap rend (projectionExprs field [])+    guard a = if null fs then Nothing else Just a++liftExpr :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a b) => a -> Expr db r b+liftExpr a = liftExpr' a++liftExpr' :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a) => a -> Expr db r b+liftExpr' a = Expr $ Snippet $ \esc pr -> renderExprExtended esc pr (toExpr a)++-- | Returns escaped table name optionally qualified with schema+{-# SPECIALIZE tableName :: (Utf8 -> Utf8) -> EntityDef -> ConstructorDef -> Utf8 #-}+tableName :: StringLike s => (s -> s) -> EntityDef -> ConstructorDef -> s+tableName esc e c = qualifySchema esc e tName where+  tName = esc $ if isSimple (constructors e)+    then fromString $ entityName e+    else fromString (entityName e) <> fromChar delim <> fromString (constrName c)++-- | Returns escaped main table name optionally qualified with schema+{-# SPECIALIZE mainTableName :: (Utf8 -> Utf8) -> EntityDef -> Utf8 #-}+mainTableName :: StringLike s => (s -> s) -> EntityDef -> s+mainTableName esc e = qualifySchema esc e tName where+  tName = esc $ fromString $ entityName e++{-# SPECIALIZE qualifySchema :: (Utf8 -> Utf8) -> EntityDef -> Utf8 -> Utf8 #-}+qualifySchema :: StringLike s => (s -> s) -> EntityDef -> s -> s+qualifySchema esc e name = maybe name (\sch -> esc (fromString sch) <> fromChar '.' <> name) $ entitySchema e

@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, OverloadedStrings #-}++-- | This module has common SQL functions and operators which are supported in the most SQL databases+module Database.Groundhog.Generic.Sql.Functions+    ( like+    , in_+    , notIn_+    , lower+    , upper+    , toArith+    , SqlDb(..)+    ) where++import Database.Groundhog.Core+import Database.Groundhog.Expression+import Database.Groundhog.Generic.Sql++in_ :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>+    a -> [b] -> Cond db r+in_ a bs = CondRaw $ Snippet $ \esc p -> [parens 45 p $ renderExpr esc (toExpr a) <> " IN (" <> commasJoin (map (renderExpr esc . toExpr) bs) <> ")"]++notIn_ :: (SqlDb db, QueryRaw db ~ Snippet db, Expression db r a, Expression db r b, PrimitivePersistField b, Unifiable a b) =>+       a -> [b] -> Cond db r+notIn_ a bs = CondRaw $ Snippet $ \esc p -> [parens 45 p $ renderExpr esc (toExpr a) <> " NOT IN (" <> commasJoin (map (renderExpr esc . toExpr) bs) <> ")"]++like :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> String -> Cond db r+like a b = CondRaw $ operator 40 " LIKE " a b++lower :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> Expr db r String+lower a = Expr $ function "lower" [toExpr a]++upper :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> Expr db r String+upper a = Expr $ function "upper" [toExpr a]++-- | Convert field to an arithmetic value. It is kept for compatibility with older Groundhog versions and can be replaced with liftExpr.+toArith :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r f a', FieldLike f db r a') => f -> Expr db r a'+toArith = liftExpr

@@ -116,17 +116,6 @@     (e, rest4) = fromPurePersistValues p rest3     in ((a, b, c, d, e), rest4) -instance Numeric Int-instance Numeric Int8-instance Numeric Int16-instance Numeric Int32-instance Numeric Int64-instance Numeric Word8-instance Numeric Word16-instance Numeric Word32-instance Numeric Word64-instance Numeric Double- instance PrimitivePersistField String where   toPrimitivePersistValue _ s = PersistString s   fromPrimitivePersistValue _ (PersistString s) = s@@ -139,6 +128,7 @@   fromPrimitivePersistValue _ (PersistZonedTime z) = show z   fromPrimitivePersistValue _ (PersistBool b) = show b   fromPrimitivePersistValue _ PersistNull = error "Unexpected NULL"+  fromPrimitivePersistValue _ (PersistCustom _ _) = error "Unexpected PersistCustom"  instance PrimitivePersistField T.Text where   toPrimitivePersistValue _ a = PersistString (T.unpack a)@@ -458,50 +448,54 @@   fromPersistValues = primFromPersistValue   dbType a = dbType ((undefined :: KeyForBackend db v -> v) a) -instance (PersistEntity v, Constructor c, PersistField a) => Projection (Field v c a) (RestrictionHolder v c) a where-  projectionFieldChains f = (fieldChain f:)+instance (PersistEntity v, Constructor c, PersistField a) => Projection (Field v c a) db (RestrictionHolder v c) a where+  projectionExprs f = (ExprField (fieldChain f):)   projectionResult _ = fromPersistValues -instance (PersistEntity v, Constructor c, PersistField a) => Projection (SubField v c a) (RestrictionHolder v c) a where-  projectionFieldChains f = (fieldChain f:)+instance (PersistEntity v, Constructor c, PersistField a) => Projection (SubField v c a) db (RestrictionHolder v c) a where+  projectionExprs f = (ExprField (fieldChain f):)   projectionResult _ = fromPersistValues -instance (PersistEntity v, Constructor c, PersistField (Key v BackendSpecific)) => Projection (AutoKeyField v c) (RestrictionHolder v c) (Key v BackendSpecific) where-  projectionFieldChains f = (fieldChain f:)+instance PersistField a => Projection (Expr db r a) db r a where+  projectionExprs e = (ExprRaw e:)   projectionResult _ = fromPersistValues -instance (PersistEntity v, Constructor c) => Projection (c (ConstructorMarker v)) (RestrictionHolder v c) v where-  projectionFieldChains c = (chains++) where+instance (PersistEntity v, Constructor c, PersistField (Key v BackendSpecific)) => Projection (AutoKeyField v c) db (RestrictionHolder v c) (Key v BackendSpecific) where+  projectionExprs f = (ExprField (fieldChain f):)+  projectionResult _ = fromPersistValues++instance (PersistEntity v, Constructor c) => Projection (c (ConstructorMarker v)) db (RestrictionHolder v c) v where+  projectionExprs c = ((map ExprField chains)++) where     chains = map (\f -> (f, [])) $ constrParams constr     e = entityDef ((undefined :: c (ConstructorMarker v) -> v) c)     constr = constructors e !! phantomConstrNum c   projectionResult c xs = toSinglePersistValue (phantomConstrNum c) >>= \cNum -> fromEntityPersistValues (cNum:xs)  instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), r ~ RestrictionHolder v (UniqueConstr (Key v (Unique u))))-      => Projection (u (UniqueMarker v)) r (Key v (Unique u)) where-  projectionFieldChains u = (chains++) where+      => Projection (u (UniqueMarker v)) db r (Key v (Unique u)) where+  projectionExprs u = ((map ExprField chains)++) where     UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)     chains = map (\f -> (f, [])) uFields     constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u))   projectionResult _ = pureFromPersistValue -instance (Projection a1 r a1', Projection a2 r a2') => Projection (a1, a2) r (a1', a2') where-  projectionFieldChains (a1, a2) = projectionFieldChains a1 . projectionFieldChains a2+instance (Projection a1 db r a1', Projection a2 db r a2') => Projection (a1, a2) db r (a1', a2') where+  projectionExprs (a1, a2) = projectionExprs a1 . projectionExprs a2   projectionResult (a', b') xs = do     (a, rest0) <- projectionResult a' xs     (b, rest1) <- projectionResult b' rest0     return ((a, b), rest1) -instance (Projection a1 r a1', Projection a2 r a2', Projection a3 r a3') => Projection (a1, a2, a3) r (a1', a2', a3') where-  projectionFieldChains (a1, a2, a3) = projectionFieldChains a1 . projectionFieldChains a2 . projectionFieldChains a3+instance (Projection a1 db r a1', Projection a2 db r a2', Projection a3 db r a3') => Projection (a1, a2, a3) db r (a1', a2', a3') where+  projectionExprs (a1, a2, a3) = projectionExprs a1 . projectionExprs a2 . projectionExprs a3   projectionResult (a', b', c') xs = do     (a, rest0) <- projectionResult a' xs     (b, rest1) <- projectionResult b' rest0     (c, rest2) <- projectionResult c' rest1     return ((a, b, c), rest2) -instance (Projection a1 r a1', Projection a2 r a2', Projection a3 r a3', Projection a4 r a4') => Projection (a1, a2, a3, a4) r (a1', a2', a3', a4') where-  projectionFieldChains (a1, a2, a3, a4) = projectionFieldChains a1 . projectionFieldChains a2 . projectionFieldChains a3 . projectionFieldChains a4+instance (Projection a1 db r a1', Projection a2 db r a2', Projection a3 db r a3', Projection a4 db r a4') => Projection (a1, a2, a3, a4) db r (a1', a2', a3', a4') where+  projectionExprs (a1, a2, a3, a4) = projectionExprs a1 . projectionExprs a2 . projectionExprs a3 . projectionExprs a4   projectionResult (a', b', c', d') xs = do     (a, rest0) <- projectionResult a' xs     (b, rest1) <- projectionResult b' rest0@@ -509,8 +503,8 @@     (d, rest3) <- projectionResult d' rest2     return ((a, b, c, d), rest3) -instance (Projection a1 r a1', Projection a2 r a2', Projection a3 r a3', Projection a4 r a4', Projection a5 r a5') => Projection (a1, a2, a3, a4, a5) r (a1', a2', a3', a4', a5') where-  projectionFieldChains (a1, a2, a3, a4, a5) = projectionFieldChains a1 . projectionFieldChains a2 . projectionFieldChains a3 . projectionFieldChains a4 . projectionFieldChains a5+instance (Projection a1 db r a1', Projection a2 db r a2', Projection a3 db r a3', Projection a4 db r a4', Projection a5 db r a5') => Projection (a1, a2, a3, a4, a5) db r (a1', a2', a3', a4', a5') where+  projectionExprs (a1, a2, a3, a4, a5) = projectionExprs a1 . projectionExprs a2 . projectionExprs a3 . projectionExprs a4 . projectionExprs a5   projectionResult (a', b', c', d', e') xs = do     (a, rest0) <- projectionResult a' xs     (b, rest1) <- projectionResult b' rest0@@ -519,20 +513,28 @@     (e, rest4) <- projectionResult e' rest3     return ((a, b, c, d, e), rest4) -instance (PersistEntity v, Constructor c, Projection (AutoKeyField v c) r a') => FieldLike (AutoKeyField v c) r a' where+instance (PersistEntity v, Constructor c, Projection (AutoKeyField v c) db r a') => Assignable (AutoKeyField v c) db r a'++instance (PersistEntity v, Constructor c, Projection (SubField v c a) db r a') => Assignable (SubField v c a) db r a'++instance (PersistEntity v, Constructor c, Projection (Field v c a) db r a') => Assignable (Field v c a) db r a'++instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) db r a') => Assignable (u (UniqueMarker v)) db r a'++instance (PersistEntity v, Constructor c, Projection (AutoKeyField v c) db r a') => FieldLike (AutoKeyField v c) db r a' where   fieldChain a = chain where-    chain = maybe (error "fieldChain AutoKeyField: constructor constrAutoKeyName == Nothing") (\idName -> ((idName, DbEntity Nothing e), [])) $ constrAutoKeyName constr+    chain = maybe (error "fieldChain AutoKeyField: constructor constrAutoKeyName == Nothing") (\idName -> ((idName, DbEntity Nothing Nothing Nothing e), [])) $ constrAutoKeyName constr     e = entityDef ((undefined :: AutoKeyField v c -> v) a)     cNum = phantomConstrNum ((undefined :: AutoKeyField v c -> c (ConstructorMarker v)) a)     constr = constructors e !! cNum -instance (PersistEntity v, Constructor c, Projection (SubField v c a) r a') => FieldLike (SubField v c a) r a' where+instance (PersistEntity v, Constructor c, Projection (SubField v c a) db r a') => FieldLike (SubField v c a) db r a' where   fieldChain (SubField a) = a -instance (PersistEntity v, Constructor c, Projection (Field v c a) r a') => FieldLike (Field v c a) r a' where+instance (PersistEntity v, Constructor c, Projection (Field v c a) db r a') => FieldLike (Field v c a) db r a' where   fieldChain = entityFieldChain -instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) r a') => FieldLike (u (UniqueMarker v)) r a' where+instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) db r a') => FieldLike (u (UniqueMarker v)) db r a' where   fieldChain u = chain where     UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)     chain = (("will_be_ignored", DbEmbedded $ EmbeddedDef True $ uFields), [])

@@ -18,7 +18,7 @@ - entity: Product |] -main = withSqliteConn ":memory:" $ runSqliteConn $ do+main = withSqliteConn ":memory:" $ runDbConn $ do   -- Customer is also migrated because Product references it.   -- It is possible to migrate schema for given type, e.g. migrate (undefined :: Customer String), or run migrateAll   runMigration defaultMigrationLogger migrateAll

@@ -18,7 +18,7 @@   persistName _ = "Point"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbOther "point"+  dbType _ = DbOther $ OtherTypeDef $ const "point"  data MobilePhone = MobilePhone {number :: String, prepaidMoney :: String, location :: Point, ipAddress :: String} deriving Show @@ -36,7 +36,7 @@           type: inet |] -main = withPostgresqlConn "dbname=test user=test password=test host=localhost" . runPostgresqlConn $ do+main = withPostgresqlConn "dbname=test user=test password=test host=localhost" . runDbConn $ do   let phone = MobilePhone "+1900 654 321" "100.456" (Point 4 6) "127.0.0.1"   runMigration defaultMigrationLogger (migrate phone)   k <- insert phone

@@ -42,7 +42,7 @@                                         # Street is not mentioned so it will have default settings.  |] -main = withSqliteConn ":memory:" $ runSqliteConn $ do+main = withSqliteConn ":memory:" $ runDbConn $ do   let address = Address "Sunnyvale" "18144" "El Camino Real"   let company = Company "Cyberdyne Systems" (False, False) address address address   runMigration defaultMigrationLogger $ migrate company

@@ -20,6 +20,8 @@       - name: Artist
         uniques:
           - name: ArtistName
+            # Optional parameter type can be constraint (by default), index, or primary
+            type: constraint
             fields: [artistName]
 |]
 
@@ -37,7 +39,14 @@ definitions:
   - entity: Album
   - entity: Track
-  # keys of many-to-many relation form a unique key
+    constructors:
+      - name: Track
+        fields:
+          - name: albumTrack
+  # Configure actions on parent table changes
+            onDelete: cascade
+            onUpdate: restrict
+  # Keys of many-to-many relation form a unique key
   - entity: ArtistAlbum
     autoKey: null
     keys:
@@ -51,7 +60,7 @@ |]
 
 main :: IO ()
-main = withSqliteConn ":memory:" $ runSqliteConn $ do
+main = withSqliteConn ":memory:" $ runDbConn $ do
   let artists = [Artist "John Lennon", Artist "George Harrison"]
       imagineAlbum = Album "Imagine"
   runMigration defaultMigrationLogger $ do
@@ -66,6 +75,6 @@   -- print first 3 tracks from any album with John Lennon
   [albumKey'] <- project AlbumField $ (ArtistField ==. ArtistNameKey "John Lennon") `limitTo` 1
   -- order by primary key
-  tracks' <- select $ (AlbumTrackField ==. albumKey') `orderBy` [Asc AutoKeyField] `limitTo` 3
+  tracks' <- select $ (AlbumTrackField ==. albumKey') `orderBy` [Desc AutoKeyField] `limitTo` 3
   liftIO $ print tracks'
 

@@ -0,0 +1,47 @@+{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, GeneralizedNewtypeDeriving, FlexibleContexts #-}+import Database.Groundhog.Core (ConnectionManager(..))+import Database.Groundhog.Generic+import Database.Groundhog.Sqlite++import Control.Applicative (Applicative)+import Control.Monad (liftM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))+import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)+import Control.Monad.Base (MonadBase (liftBase))+import Control.Monad.Reader (MonadReader(..))+import Data.Conduit.Pool++main :: IO ()+main = withSqlitePool ":memory:" 5 $ \pconn ->+    runReaderT (runMyMonad sqliteDbAction) (ApplicationState pconn)++-- It is connection agnostic (runs both with Sqlite and Pool Sqlite)+sqliteDbAction :: (MonadBaseControl IO m, HasConn m cm Sqlite) => m ()+sqliteDbAction = do+  -- here can be web business logics+  runDb $ do+    let runAndShow sql = queryRaw False sql [] (>>= liftIO . print)+    runAndShow "select 'Groundhog embedded in arbitrary monadic context'"+    withSavepoint "savepoint_name" $ do+      runAndShow "select 'SQL inside savepoint'"++-- It is like Snaplet in Snap or foundation datatype in Yesod.+data ApplicationState = ApplicationState { getConnPool :: Pool Sqlite }++-- This instance extracts connection from our application state+instance ConnectionManager ApplicationState Sqlite where+  withConn f app = withConn f (getConnPool app)+  withConnNoTransaction f app = withConnNoTransaction f (getConnPool app)++-- This can be any application monad like Handler in Snap or GHandler in Yesod+newtype MyMonad a = MyMonad { runMyMonad :: ReaderT ApplicationState IO a }+  deriving (Applicative, Functor, Monad, MonadReader ApplicationState, MonadIO)++instance MonadBase IO MyMonad where+  liftBase = liftIO++instance MonadBaseControl IO MyMonad where+  newtype StM MyMonad a = StMMyMonad { unStMMyMonad :: StM (ReaderT ApplicationState IO) a }+  liftBaseWith f = MyMonad (liftBaseWith (\run -> f (liftM StMMyMonad . run . runMyMonad)))+  restoreM = MyMonad . restoreM . unStMMyMonad

@@ -1,11 +1,11 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-} import Control.Monad import Control.Monad.IO.Class (liftIO)-import Data.ByteString+import qualified Data.ByteString.Char8 as BS import Database.Groundhog.TH import Database.Groundhog.Sqlite -data User = User {name :: String, phoneNumber :: (String, String), bigAvatar :: ByteString} deriving (Eq, Show)+data User = User {name :: String, phoneNumber :: (String, String), bigAvatar :: BS.ByteString} deriving (Eq, Show)  mkPersist defaultCodegenConfig [groundhog| definitions:@@ -20,15 +20,16 @@ |]  main :: IO ()-main = withSqliteConn ":memory:" $ runSqliteConn $ do-  let jack = User "Jack" ("+380", "12-345-67-89") "BMP"-      jill = User "Jill" ("+1", "98-765-43-12") "BMP"+main = withSqliteConn ":memory:" $ runDbConn $ do+  let jack = User "Jack" ("+380", "12-345-67-89") (BS.pack "BMP")+      jill = User "Jill" ("+1", "98-765-43-12") (BS.pack "BMP")   runMigration defaultMigrationLogger $ migrate jack   mapM_ insert [jack, jill]-  -- get phones of the users. Only the required fields are fetched. Function project supports both regular and subfields-  phones <- project (PhoneNumberField ~> Tuple2_1Selector) $ (() ==. ()) `orderBy` [Asc AutoKeyField]+  -- get usernames and phones. Only the required fields are fetched (phone in this case). Function project supports both regular and subfields. The expressions may have complex structure which includes SQL operators and functions+  liftIO $ putStrLn "Uppercase usernames and phones"+  phones <- project (upper ("username: " `append` NameField), PhoneNumberField ~> Tuple2_1Selector) $ (lower NameField `like` "ja%") `orderBy` [Asc AutoKeyField]   liftIO $ print phones   -- we can also use 'project' as a replacement for 'select' with extended options.-  -- the special datatype 'AutoKeyField' projects to the entity autokey, unique key phantoms project to keys, and the constructor phantoms project to the data itself+  liftIO $ putStrLn "The special datatype 'AutoKeyField' projects to the entity autokey, unique key phantoms project to keys, and the constructor phantoms project to the data itself"   withIds <- project (AutoKeyField, Unique_name, UserConstructor) (() ==. ())   liftIO $ print withIds

@@ -12,7 +12,7 @@ - entity: SomeData |] -main = withSqliteConn ":memory:" $ runSqliteConn $ do+main = withSqliteConn ":memory:" $ runDbConn $ do   runMigration defaultMigrationLogger $ migrate (undefined :: SomeData)   k1 <- insert $ SomeData 1 (2, "abc")   k2 <- insert $ SomeData 10 (20, "def")

@@ -17,7 +17,7 @@           exprName: CircleRadius        # The default value defined by naming style was RadiusField |] -main = withSqliteConn ":memory:" $ runSqliteConn $ do+main = withSqliteConn ":memory:" $ runDbConn $ do   let circle = Circle 5   -- Both table for Circle and for Triangle of the Shape datatype are migrated.   runMigration defaultMigrationLogger $ migrate circle

@@ -7,16 +7,16 @@ data Table = Create {select :: String, update :: Int, fubar :: String} deriving (Eq, Show)  mkPersist defaultCodegenConfig $ PersistDefinitions [-  Left $ PSEntityDef "Table" Nothing Nothing Nothing $ Just [+  Left $ PSEntityDef "Table" Nothing Nothing Nothing Nothing $ Just [     PSConstructorDef "Create" Nothing Nothing Nothing (Just [-        PSFieldDef "select" (Just "SELECT") Nothing Nothing-      , PSFieldDef "fubar" (Just "BEGIN COMMIT") Nothing Nothing+        PSFieldDef "select" (Just "SELECT") Nothing Nothing Nothing+      , PSFieldDef "fubar" (Just "BEGIN COMMIT") Nothing Nothing Nothing       ])       Nothing     ]   ] -main = withSqliteConn ":memory:" $ runSqliteConn $ do+main = withSqliteConn ":memory:" $ runDbConn $ do   let table = Create "DROP" maxBound "DELETE"   runMigration defaultMigrationLogger $ migrate table   k <- insert table

@@ -1,11 +1,11 @@ name:            groundhog-version:         0.2.0+version:         0.3.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com> maintainer:      Boris Lykah <lykahb@gmail.com>-synopsis:        Type-safe ADT-database mapping library.-description:     This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful.+synopsis:        Type-safe datatype-database mapping library.+description:     This library maps your datatypes to a relational model, in a way similar to what ORM libraries do in OOP. The schema can be configured flexibly which makes integration with existing databases easy. Groundhog supports schema migrations, composite keys, compositional queries, and much more. See the folder with examples for introduction. category:        Database stability:       Non-stable cabal-version:   >= 1.6@@ -17,8 +17,10 @@     build-depends:   base                     >= 4         && < 5                    , bytestring               >= 0.9                    , transformers             >= 0.2.1     && < 0.4+                   , mtl                      >= 2.0                    , time                     >= 1.1.4                    , text                     >= 0.8       && < 0.12+                   , blaze-builder            >= 0.3.0.0   && < 0.4                    , containers               >= 0.2                    , monad-control            >= 0.3       && < 0.4                    , transformers-base@@ -28,6 +30,7 @@                      Database.Groundhog.Generic                      Database.Groundhog.Generic.Migration                      Database.Groundhog.Generic.Sql+                     Database.Groundhog.Generic.Sql.Functions                      Database.Groundhog.Generic.PersistBackendHelpers                      Database.Groundhog.Instances     ghc-options:     -Wall