groundhog 0.3.1.1 → 0.4.0

raw patch · 19 files changed

+329/−694 lines, 19 filesdep +monad-loggerdep ~blaze-builderdep ~monad-controldep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: monad-logger

Dependency ranges changed: blaze-builder, monad-control, text, transformers

API changes (from Hackage documentation)

Files

• Database/Groundhog.hs +1/−1
• Database/Groundhog/Core.hs +56/−40
• Database/Groundhog/Expression.hs +33/−32
• Database/Groundhog/Generic.hs +43/−37
• Database/Groundhog/Generic/Migration.hs +103/−103
• Database/Groundhog/Generic/PersistBackendHelpers.hs +23/−26
• Database/Groundhog/Generic/Sql.hs +3/−6
• Database/Groundhog/Generic/Sql/Functions.hs +4/−0
• Database/Groundhog/Instances.hs +54/−40
• examples/basic.hs +0/−36
• examples/dbSpecificTypes.hs +0/−56
• examples/embedded.hs +0/−60
• examples/keys.hs +0/−77
• examples/monadIntegration.hs +0/−47
• examples/projections.hs +0/−35
• examples/rawQueries.hs +0/−36
• examples/sumTypes.hs +0/−30
• examples/withoutQuasiQuotes.hs +0/−23
• groundhog.cabal +9/−9

@@ -1,6 +1,6 @@ -- | This module exports the most commonly used functions and datatypes. ----- See the @examples@ directory in the package archive or <http://github.com/lykahb/groundhog/tree/master/examples>.+-- See <http://github.com/lykahb/groundhog/blob/master/examples/>.  module Database.Groundhog (   -- * Main definitions

@@ -45,16 +45,19 @@   , offsetBy   , orderBy   -- * Type description+  , DbTypePrimitive(..)   , DbType(..)   , EntityDef(..)   , EmbeddedDef(..)   , OtherTypeDef(..)   , ConstructorDef(..)   , Constructor(..)+  , EntityConstr(..)   , IsUniqueKey(..)   , UniqueDef(..)   , UniqueType(..)   , ReferenceActionType(..)+  , ParentTableReference   -- * Migration   , SingleMigration   , NamedMigrations@@ -69,12 +72,12 @@   , ConnectionManager(..)   , SingleConnectionManager   , Savepoint(..)-  , runDbConn   ) where  import Blaze.ByteString.Builder (Builder, toByteString) import Control.Applicative (Applicative) import Control.Monad.Base (MonadBase (liftBase))+import Control.Monad.Logger (MonadLogger(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl (..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, MonadTransControl (..))@@ -100,6 +103,8 @@   type AutoKey v   -- | This type is the default key for the entity.   type DefaultKey v+  -- | It is HFalse for entity with one constructor and HTrue for sum types.+  type IsSumType v   -- | Returns a complete description of the type   entityDef :: v -> EntityDef   -- | Marshalls value to a list of 'PersistValue' ready for insert to a database@@ -136,6 +141,7 @@   | Not (Cond db r)   | Compare ExprRelation (UntypedExpr db r) (UntypedExpr db r)   | CondRaw (QueryRaw db r)+  | CondEmpty  data ExprRelation = Eq | Ne | Gt | Lt | Ge | Le deriving Show @@ -168,20 +174,19 @@  infixl 5 ~> -- | Accesses fields of the embedded datatypes. For example, @SomeField ==. (\"abc\", \"def\") ||. SomeField ~> Tuple2_0Selector ==. \"def\"@-(~>) :: (PersistEntity v, Constructor c, FieldLike f db (RestrictionHolder v c) a, Embedded a) => f -> Selector a a' -> SubField v c a'+(~>) :: (EntityConstr v 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)     other -> error $ "(~>): cannot get subfield of non-embedded type " ++ show other  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)@+-- | It can be used in expressions like a regular field.+-- For example, @delete (AutoKeyField ==. k)@ -- or @delete (AutoKeyField ==. k ||. SomeField ==. \"DUPLICATE\")@-data AutoKeyField v c where-  AutoKeyField :: (PersistEntity v, Constructor c) => AutoKeyField v c+data AutoKeyField v (c :: (* -> *) -> *) where+  AutoKeyField :: AutoKeyField v c  data RestrictionHolder v (c :: (* -> *) -> *) @@ -239,6 +244,9 @@   liftBaseWith = defaultLiftBaseWith StMSP   restoreM     = defaultRestoreM   unStMSP +instance MonadLogger m => MonadLogger (DbPersist conn m) where+    monadLoggerLog a b c = lift . monadLoggerLog a b c+ runDbPersist :: Monad m => DbPersist conn m a -> conn -> m a runDbPersist = runReaderT . unDbPersist @@ -266,7 +274,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. Example: @select $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`limitTo\` 100@-  select        :: (PersistEntity v, Constructor c, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))+  select        :: (PersistEntity v, EntityConstr v 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)]@@ -275,17 +283,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. Example: @update [FirstField =. \"abc\"] $ FirstField ==. \"def\"@-  update        :: (PersistEntity v, Constructor c) => [Update (PhantomDb m) (RestrictionHolder v c)] -> Cond (PhantomDb m) (RestrictionHolder v c) -> m ()+  update        :: (PersistEntity v, EntityConstr v 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 (PhantomDb m) (RestrictionHolder v c) -> m ()+  delete        :: (PersistEntity v, EntityConstr v 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 (PhantomDb m) (RestrictionHolder v c) -> m Int+  count         :: (PersistEntity v, EntityConstr v 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. Example: @project (SecondField, ThirdField) $ (FirstField ==. \"abc\" &&. SecondField >. \"def\") \`orderBy\` [Asc ThirdField] \`offsetBy\` 100@-  project       :: (PersistEntity v, Constructor c, Projection p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))+  project       :: (PersistEntity v, EntityConstr v c, Projection p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))                 => p                 -> opts                 -> m [a]@@ -346,12 +354,16 @@   -- returning ConstructorDef seems more logical, but it would require the value datatype   -- it can be supplied either as a part of constructor type, eg instance Constructor (MyDataConstructor (MyData a)) which requires -XFlexibleInstances   -- or as a separate type, eg instance Constructor MyDataConstructor (MyData a) which requires -XMultiParamTypeClasses-  -- the phantoms are primarily used to get the constructor name. So to keep user code cleaner we return only the name and number, which can be later used to get ConstructorDef from the EntityDef-  phantomConstrName :: c (a :: * -> *) -> String+  -- | Returns constructor index which can be used to get ConstructorDef from EntityDef   phantomConstrNum :: c (a :: * -> *) -> Int -class (Constructor (UniqueConstr uKey), PurePersistField uKey) => IsUniqueKey uKey where-  type UniqueConstr uKey :: (* -> *) -> *+-- | This class helps type inference in cases when query does not contain any fields which+-- define the constructor, but the entity has only one.+-- For example, in @select $ AutoKeyField ==. k@ the condition would need type annotation with constructor name only if we select a sum type.+class PersistEntity v => EntityConstr v c where+  entityConstrNum :: Proxy v -> c (a :: * -> *) -> Int++class PurePersistField uKey => IsUniqueKey uKey where   -- | Creates value of unique key using the data extracted from the passed value   extractUnique :: uKey ~ Key v u => v -> uKey   -- | Ordinal number of the unique constraint in the list returned by 'constrUniques'@@ -376,28 +388,36 @@  -- | 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.-data DbType = DbString-            | DbInt32-            | DbInt64-            | DbReal-            | DbBool-            | DbDay-            | DbTime-            | DbDayTime-            | DbDayTimeZoned-            | DbBlob         -- ^ ByteString-            | 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. Then there are actions on delete and on update.-            | DbEntity (Maybe (EmbeddedDef, String)) (Maybe ReferenceActionType) (Maybe ReferenceActionType) EntityDef+-- have different representations for these types.+data DbTypePrimitive =+      DbString+    | DbInt32+    | DbInt64+    | DbReal+    | DbBool+    | DbDay+    | DbTime+    | DbDayTime+    | DbDayTimeZoned+    | DbBlob         -- ^ ByteString+    | DbOther OtherTypeDef+    | DbAutoKey   deriving (Eq, Show)+data DbType = +    -- | type, nullable, default value, reference+      DbTypePrimitive DbTypePrimitive Bool (Maybe String) (Maybe ParentTableReference)+    | DbEmbedded EmbeddedDef (Maybe ParentTableReference)+    | DbList String DbType -- ^ List table name and type of its argument+  deriving (Eq, Show) +-- | The reference contains either EntityDef of the parent table and name of the unique constraint. Or for tables not mapped by Groundhog schema name, table name, and list of columns  +-- Reference to the autogenerated key of a mapped entity = (Left (entityDef, Nothing), onDelete, onUpdate)+-- Reference to a unique key of a mapped entity = (Left (entityDef, Just uniqueKeyName), onDelete, onUpdate)+-- Reference to a table that is not mapped = (Right (schema, tableName, columns), onDelete, onUpdate)+type ParentTableReference = (Either (EntityDef, Maybe String) (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType)+ -- | Stores name for a database type-newtype OtherTypeDef = OtherTypeDef ((DbType -> String) -> String)+newtype OtherTypeDef = OtherTypeDef ((DbTypePrimitive -> String) -> String)  instance Eq OtherTypeDef where   OtherTypeDef f1 == OtherTypeDef f2 = f1 show == f2 show@@ -504,7 +524,3 @@ 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

@@ -22,10 +22,11 @@ import Database.Groundhog.Core
 import Database.Groundhog.Instances ()
 
--- | Instances of this type can be converted to 'Expr'. It is useful for uniform manipulation over fields and plain values
+-- | Instances of this type can be converted to 'UntypedExpr'. It is useful for uniform manipulation over fields, constant values, etc.
 class Expression db r a where
   toExpr :: a -> UntypedExpr db r
 
+-- | This helper class can make type signatures more concise
 class (Expression db r a, Unifiable a a') => ExpressionOf db r a a'
 
 instance (Expression db r a, Unifiable a a') => ExpressionOf db r a a'
@@ -36,16 +37,16 @@ instance (PersistField a, db' ~ db, r' ~ r) => Expression db' r' (Expr db r a) where
   toExpr = ExprRaw
 
-instance (PersistEntity v, Constructor c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
+instance (EntityConstr v c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (Field v c a) where
   toExpr = ExprField . fieldChain
 
-instance (PersistEntity v, Constructor c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (SubField v c a) where
+instance (EntityConstr v c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (SubField v c a) where
   toExpr = ExprField . fieldChain
 
-instance (PersistEntity v, Constructor c, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where
+instance (EntityConstr v c, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where
   toExpr = ExprField . fieldChain
 
-instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v (UniqueConstr k) ~ r')
+instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v c ~ r')
       => Expression db r' (u (UniqueMarker v)) where
   toExpr = ExprField . fieldChain
 
@@ -57,38 +58,38 @@ instance (Normalize bk a (ak, r), Normalize ak b (bk, r)) => Unifiable a b
 
 class Normalize counterpart t r | t -> r
-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 (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
-
-class NormalizeValue counterpart isPlain t r | t isPlain -> r
-instance NormalizeValue' t (isPlain, r) => NormalizeValue HFalse HFalse t (HFalse, r)
-instance NormalizeValue' t (isPlain, r) => NormalizeValue HFalse HTrue t (isPlain, r)
-instance r ~ (isPlain, t) => NormalizeValue HTrue isPlain t r
+instance NormalizeValue a (isPlain, r) => Normalize HFalse (Field v c a) (HFalse, r)
+instance r ~ (HFalse, a)               => Normalize HTrue  (Field v c a) r
+instance NormalizeValue a (isPlain, r) => Normalize HFalse (SubField v c a) (HFalse, r)
+instance r ~ (HFalse, a)               => Normalize HTrue  (SubField v c a) r
+instance NormalizeValue a (isPlain, r) => Normalize HFalse (Expr db r' a) (HFalse, r)
+instance r ~ (HFalse, a)               => Normalize HTrue  (Expr db r' a) r
+instance NormalizeValue (Key v (Unique u)) (isPlain, r) => Normalize HFalse (u (UniqueMarker v)) (HFalse, r)
+instance r ~ (HFalse, Key v (Unique u))                 => Normalize HTrue  (u (UniqueMarker v)) r
+instance NormalizeValue (Key v BackendSpecific) (isPlain, r) => Normalize HFalse (AutoKeyField v c) (HFalse, r)
+instance r ~ (HFalse, Key v BackendSpecific)                 => Normalize HTrue  (AutoKeyField v c) r
+instance NormalizeValue t r => Normalize HFalse t r
+instance r ~ (HTrue, t)     => Normalize HTrue  t r
 
-class NormalizeValue' t r | t -> r
+class NormalizeValue t r | t -> r
 -- Normalize @Key v u@ to @v@ only if this key is used for storing @v@.
-instance (TypeEq (DefaultKey a) (Key a u) isDef,
-         r ~ (Not isDef, Maybe (NormalizeKey isDef (Key a u))))
-         => NormalizeValue' (Maybe (Key a u)) r
-instance (TypeEq (DefaultKey a) (Key a u) isDef,
-         r ~ (Not isDef, NormalizeKey isDef (Key a u)))
-         => NormalizeValue' (Key a u) r
-instance r ~ (HTrue, a) => NormalizeValue' a r
+instance (TypeEq (DefaultKey v) (Key v u) isDef,
+         NormalizeKey isDef (Key v u) k,
+         r ~ (Not isDef, Maybe k))
+         => NormalizeValue (Maybe (Key v u)) r
+instance (TypeEq (DefaultKey v) (Key v u) isDef,
+         NormalizeKey isDef (Key v u) k,
+         r ~ (Not isDef, k))
+         => NormalizeValue (Key v u) r
+instance r ~ (HTrue, a) => NormalizeValue a r
 
 class TypeEq x y b | x y -> b
-instance (b ~ HFalse) => TypeEq x y b	 
+instance b ~ HFalse => TypeEq x y b
 instance TypeEq x x HTrue
 
-type family NormalizeKey isDef key
-type instance NormalizeKey HTrue (Key a u) = a
-type instance NormalizeKey HFalse a = a
+class NormalizeKey isDef key r | isDef key -> r, r -> key
+instance r ~ v => NormalizeKey HTrue (Key v u) r
+instance r ~ a => NormalizeKey HFalse a r
 
 type family Not bool
 type instance Not HTrue  = HFalse
@@ -106,7 +107,7 @@ -- | Boolean \"and\" operator.
 (&&.) :: Cond db r -> Cond db r -> Cond db r
 
--- | Boolean \"or\" operator.  
+-- | Boolean \"or\" operator.
 (||.) :: Cond db r -> Cond db r -> Cond db r
 
 infixr 3 &&.

@@ -14,9 +14,10 @@   , silentMigrationLogger   , defaultMigrationLogger   , failMessage-  -- * Helpers for running Groundhog within custom monads+  -- * Helpers for running Groundhog actions   , HasConn   , runDb+  , runDbConn   , withSavepoint   -- * Helper functions for defining *PersistValue instances   , primToPersistValue@@ -39,9 +40,8 @@   , bracket   , finally   , onException-  , PSEmbeddedFieldDef(..)-  , applyEmbeddedDbTypeSettings-  , applyReferencesSettings+  , PSFieldDef(..)+  , applyDbTypeSettings   , findOne   , replaceOne   , matchElements@@ -53,8 +53,10 @@  import Database.Groundhog.Core +import Control.Applicative ((<|>)) import Control.Monad (liftM, forM_, (>=>))-import Control.Monad.Trans.State (StateT (..))+import Control.Monad.Logger (MonadLogger, NoLoggingT(..))+import Control.Monad.Trans.State (StateT(..)) import Control.Monad.Trans.Control (MonadBaseControl, control, restoreM) import qualified Control.Exception as E import Control.Monad.IO.Class (MonadIO (..))@@ -155,38 +157,39 @@         -> m a onException io what = control $ \runInIO -> E.onException (runInIO io) (runInIO what) -data PSEmbeddedFieldDef = PSEmbeddedFieldDef {-    psEmbeddedFieldName :: String -- bar-  , psDbEmbeddedFieldName :: Maybe String -- SQLbar-  , psDbEmbeddedTypeName :: Maybe String -- inet, NUMERIC(5, 2), VARCHAR(50)-  , psSubEmbedded :: Maybe [PSEmbeddedFieldDef]+data PSFieldDef = PSFieldDef {+    psFieldName :: String -- bar+  , psDbFieldName :: Maybe String -- SQLbar+  , psDbTypeName :: Maybe String -- inet, NUMERIC(5,2), VARCHAR(50)+  , psExprName :: Maybe String -- BarField+  , psEmbeddedDef :: Maybe [PSFieldDef]+  , psDefaultValue :: Maybe String+  , psReferenceParent :: Maybe (Maybe (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) } deriving Show -applyEmbeddedDbTypeSettings :: [PSEmbeddedFieldDef] -> DbType -> DbType-applyEmbeddedDbTypeSettings settings typ = (case typ of-  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) = uncurry EmbeddedDef $ go settings fields+applyDbTypeSettings :: PSFieldDef -> DbType -> DbType+applyDbTypeSettings (PSFieldDef _ _ dbTypeName _ Nothing def psRef) typ = case typ of+  DbTypePrimitive t nullable def' ref -> DbTypePrimitive (maybe t (DbOther . OtherTypeDef . const) dbTypeName) nullable (def <|> def') (applyReferencesSettings psRef ref)+  DbEmbedded emb ref -> DbEmbedded emb (applyReferencesSettings psRef ref)+  t -> t+applyDbTypeSettings (PSFieldDef _ _ _ _ (Just subs) _ psRef) typ = (case typ of+  DbEmbedded (EmbeddedDef _ fields) ref -> DbEmbedded (uncurry EmbeddedDef $ go subs fields) (applyReferencesSettings psRef ref)+  t -> error $ "applyDbTypeSettings: expected DbEmbedded, got " ++ show t) where   go [] fs = (False, fs)-  go st [] = error $ "applyEmbeddedDbTypeSettings: embedded datatype does not have following fields: " ++ show st-  go st (f@(fName, fType):fs) = case partition ((== fName) . psEmbeddedFieldName) st of-    ([PSEmbeddedFieldDef _ dbName dbTypeName subs], rest) -> result where+  go st [] = error $ "applyDbTypeSettings: embedded datatype does not have expected fields: " ++ show st+  go st (field@(fName, fType):fs) = case partition ((== fName) . psFieldName) st of+    ([fDef], rest) -> result where       (flag, fields') = go rest fs-      result = case dbName of-        Nothing -> (flag, (fName, typ'):fields')-        Just name' -> (True, (name', typ'):fields')-      typ' = case (subs, dbTypeName) of-        (Just e, _) -> applyEmbeddedDbTypeSettings e fType-        (_, Just typeName) -> DbOther (OtherTypeDef $ const typeName)-        _ -> fType-    _ -> let (flag, fields') = go st fs in (flag, f:fields')+      result = case psDbFieldName fDef of+        Nothing -> (flag, (fName, applyDbTypeSettings fDef fType):fields')+        Just name' -> (True, (name', applyDbTypeSettings fDef fType):fields')+    _ -> let (flag, fields') = go st fs in (flag, field:fields') -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+applyReferencesSettings :: Maybe (Maybe (Maybe String, String, [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) -> Maybe ParentTableReference -> Maybe ParentTableReference+applyReferencesSettings Nothing ref = ref+applyReferencesSettings (Just (parent, onDel, onUpd)) (Just (parent', onDel', onUpd')) = Just (maybe parent' Right parent, onDel <|> onDel', onUpd <|> onUpd')+applyReferencesSettings (Just (Just parent, onDel, onUpd)) Nothing = Just (Right parent, onDel, onUpd)+applyReferencesSettings _ Nothing = error $ "applyReferencesSettings: expected type with reference, got Nothing"  primToPersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m ([PersistValue] -> [PersistValue]) primToPersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a:)@@ -275,7 +278,6 @@ mapAllRows f pop = go where   go = pop >>= maybe (return []) (f >=> \a -> liftM (a:) go) - phantomDb :: PersistBackend m => m (Proxy (PhantomDb m)) phantomDb = return $ error "phantomDb" @@ -284,12 +286,16 @@ 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+class (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadReader cm m, ConnectionManager cm conn) => HasConn m cm conn+instance (MonadIO m, MonadLogger 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+runDb :: HasConn m cm conn => DbPersist conn m a -> m a+runDb f = ask >>= withConn (runDbPersist f)++-- | 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 (NoLoggingT m) a -> cm -> m a+runDbConn f cm = runNoLoggingT (withConn (runDbPersist f) cm)  -- | It helps to run 'withConnSavepoint' within a monad. withSavepoint :: (HasConn m cm conn, SingleConnectionManager cm conn, Savepoint conn) => String -> m a -> m a

@@ -31,12 +31,12 @@ import Data.Function (on) import qualified Data.Map as Map import Data.List (group, intercalate)-import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)+import Data.Maybe (fromMaybe, mapMaybe)  data Column = Column     { colName :: String     , colNull :: Bool-    , colType :: DbType -- ^ contains DbType that maps to one column (no DbEmbedded)+    , colType :: DbTypePrimitive     , colDefault :: Maybe String     } deriving (Eq, Show) @@ -55,7 +55,7 @@   , tableReferences :: [(Maybe String, Reference)] } deriving Show -data AlterColumn = Type DbType | IsNull | NotNull+data AlterColumn = Type DbTypePrimitive | IsNull | NotNull                  | Default String | NoDefault | UpdateValue String deriving Show  data AlterTable = AddUnique UniqueDef'@@ -89,55 +89,65 @@ } deriving Show  data MigrationPack m = MigrationPack {-    compareTypes :: DbType -> DbType -> Bool+    compareTypes :: DbTypePrimitive -> DbTypePrimitive -> Bool   , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool   , compareUniqs :: UniqueDef' -> UniqueDef' -> Bool+  , compareDefaults :: String -> String -> Bool   , 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 :: 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   , addUniquesReferences :: [UniqueDef'] -> [Reference] -> ([String], [AlterTable])   , showColumn :: Column -> String   , showAlterDb :: AlterDB -> SingleMigration+  , defaultReferenceActionType :: ReferenceActionType } -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)) onDel onUpd e  -> (cols, ref:refs) where-      (cols, refs) = go prefix (fname, DbEmbedded emb)-      ref = Reference (entitySchema e) (entityName e) (zipWith' (curry $ colName *** colName) cols foreignColumns) onDel onUpd+mkColumns :: (String, DbType) -> ([Column] -> [Column])+mkColumns = go "" where+  go prefix (fname, typ) acc = (case typ of+    DbEmbedded (EmbeddedDef flag ts) _ -> foldr (go prefix') acc ts where prefix' = if flag then "" else prefix ++ fname ++ [delim]+    DbList _ _ -> Column fullName False DbAutoKey Nothing : acc+    DbTypePrimitive t nullable def _ -> Column fullName nullable t def : acc) where+      fullName = prefix ++ fname++mkReferences :: (String, DbType) -> [Reference]+mkReferences = concat . traverseDbType f where+  f (DbEmbedded _ ref) cols = maybe [] (return . mkReference cols) ref+  f (DbList lName _) cols = [mkReference cols (Right (Nothing, lName, ["id"]), Nothing, Nothing)]+  f (DbTypePrimitive _ _ _ ref) cols = maybe [] (return . mkReference cols) ref+  mkReference :: [String] -> ParentTableReference -> Reference+  mkReference cols (parent, onDel, onUpd) = case parent of+    Left (e, Nothing) -> Reference (entitySchema e) (entityName e) (zipWith' (,) cols [keyName]) onDel onUpd where+      keyName = case constructors e of+        [cDef] -> fromMaybe (error "mkReferences: autokey name is Nothing") $ constrAutoKeyName cDef+        _      -> "id"+    Left (e, (Just uName)) -> Reference (entitySchema e) (entityName e) (zipWith' (,) cols (map colName parentColumns)) onDel onUpd where       cDef = case constructors e of         [cDef'] -> cDef'-        _       -> error "mkColumns: datatype with unique key cannot have more than one constructor"+        _       -> error "mkReferences: 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 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 t Nothing], refs) where-      -- TODO: schema-      refs = [Reference Nothing lName [(name, "id")] Nothing Nothing]-    t -> ([Column name False t Nothing], [])) where+      parentColumns = foldr mkColumns [] fields+    Right (sch, table, parentColumns) -> Reference sch table (zipWith' (,) cols parentColumns) onDel onUpd+  zipWith' _ [] [] = []+  zipWith' g (x:xs) (y:ys) = g x y: zipWith' g xs ys+  zipWith' _ _ _ = error "mkReferences: the lists have different length"++traverseDbType :: (DbType -> [String] -> a) -> (String, DbType) -> [a]+traverseDbType f (columnName, dbtype) = snd $ go "" (columnName, dbtype) where+  go prefix (fname, typ) = (case typ of+    t@(DbEmbedded (EmbeddedDef flag ts) _) -> (cols, f t cols : xs) where+      prefix' = if flag then "" else prefix ++ fname ++ [delim]+      (cols, xs) = concatMap' (go prefix') ts+    t@(DbList _ _) -> ([name], [f t [name]])+    t@(DbTypePrimitive _ _ _ _) -> ([name], [f t [name]])) where       name = prefix ++ fname-      concatMap' f xs = concat *** concat $ unzip $ map f xs-      zipWith' _ [] [] = []-      zipWith' f (x:xs) (y:ys) = f x y: zipWith' f xs ys-      zipWith' _ _ _ = error "mkColumns: the lists have different length"+      concatMap' g xs = concat *** concat $ unzip $ map g xs  -- | Create migration for a given entity and all entities it depends on. -- The stateful Map is used to avoid duplicate migrations when an entity type@@ -149,89 +159,84 @@   -> 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 (DbMaybe t)        = go t-  go (DbEmbedded (EmbeddedDef _ ts))  = mapM_ (go . snd) ts-  go _                  = return ()    -- ordinary types need not migration+  go (DbEmbedded (EmbeddedDef _ ts) ref) = mapM_ (go . snd) ts >> migRef ref+  go (DbTypePrimitive _ _ _ ref) = migRef ref   f name mig cont = do     v <- gets (Map.lookup name)     case v of       Nothing -> lift mig >>= modify . Map.insert name >> cont       _ -> return ()   allSubtypes = map snd . concatMap constrParams . constructors+  -- TODO: use schema-qualified name+  migRef ref = case ref of+    Just (Left (e, _), _, _) -> f (entityName e) (migE e) (mapM_ go (allSubtypes e))+    _ -> return ()  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 ++ " " ++ primaryKeyTypeName ++ ", discr INTEGER NOT NULL)"-  let expectedMainStructure = TableInfo [Column "id" False primaryKeyType Nothing, Column "discr" False DbInt32 Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []+      constrs = constructors e+      mainTableQuery = "CREATE TABLE " ++ escape name ++ " (" ++ mainTableId ++ " " ++ primaryKeyTypeName ++ ", discr INTEGER NOT NULL)"+      expectedMainStructure = TableInfo [Column "id" False DbAutoKey Nothing, Column "discr" False DbInt32 Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []    if isSimple constrs     then do       x <- analyzeTable (entitySchema e) name       -- check whether the table was created for multiple constructors before       case x of-        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]-        Right _ -> liftM snd $ migConstr m e $ head constrs-        Left errs -> return (Left errs)+        Just old | null $ getAlters m old expectedMainStructure -> return $ Left+          ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]+        _ -> liftM snd $ migConstr m e $ head constrs     else do       mainStructure <- analyzeTable (entitySchema e) name       let constrTable c = name ++ [delim] ++ constrName c       res <- mapM (migConstr m e) constrs-      case mainStructure of-        Right Nothing -> do+      return $ case mainStructure of+        Nothing ->            -- no constructor tables can exist if there is no main data table           let orphans = filter (fst . fst) $ zip res constrs-          return $ if null orphans+          in if null orphans             then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)]:map snd res             else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans-        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-              let updateDiscriminators = Right . go 0 . map (head &&& length) . group . map fst $ res where+        Just mainStructure' -> if null $ getAlters m mainStructure' expectedMainStructure+          then let+               -- 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+               updateDiscriminators = go 0 . map (head &&& length) . group . map fst $ res where                   go acc ((False, n):(True, n2):xs) = (False, defaultPriority, "UPDATE " ++ escape name ++ " SET discr = discr + " ++ show n ++ " WHERE discr >= " ++ show acc) : go (acc + n + n2) xs                   go acc ((True, n):xs) = go (acc + n) xs                   go _ _ = []-              return $ mergeMigrations $ updateDiscriminators: (map snd res)-            else return $ Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure']-        Left errs -> return (Left errs)+               in mergeMigrations $ Right updateDiscriminators: map snd res+          else Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show mainStructure']  migrateList :: (Monad m, SchemaAnalyzer m) => MigrationPack m -> DbType -> m SingleMigration migrateList m@MigrationPack{..} (DbList mainName t) = do   let valuesName = mainName ++ delim : "values"-      (valueCols, valueRefs) = mkColumns "value" t+      (valueCols, valueRefs) = (($ []) . mkColumns) &&& mkReferences $ ("value", t)       refs' = Reference Nothing mainName [("id", "id")] (Just Cascade) Nothing : valueRefs+      expectedMainStructure = TableInfo [Column "id" False DbAutoKey Nothing] [UniqueDef' Nothing UniquePrimary ["id"]] []       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')+      valueColumns = Column "id" False DbAutoKey Nothing : Column "ord" False DbInt32 Nothing : valueCols+      valuesQuery = "CREATE TABLE " ++ escape valuesName ++ " (" ++ intercalate ", " (map showColumn valueColumns ++ addInCreate) ++ ")"   -- TODO: handle case when outer entity has a schema   mainStructure <- analyzeTable Nothing mainName   valuesStructure <- analyzeTable Nothing valuesName   let triggerMain = []-  (_, triggerValues) <- migTriggerOnDelete Nothing valuesName $ mkDeletes m valueCols+  (_, triggerValues) <- migTriggerOnDelete Nothing valuesName $ mkDeletes escape ("value", t)   return $ case (mainStructure, valuesStructure) of-    (Right Nothing, Right Nothing) -> let+    (Nothing, Nothing) -> let       rest = [AlterTable Nothing valuesName valuesQuery expectedValuesStructure expectedValuesStructure addInAlters]       in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues-    (Right (Just mainStructure'), Right (Just valuesStructure')) -> let+    (Just mainStructure', 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-    (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]+    (_, Nothing) -> Left ["Found orphan main list table " ++ mainName]+    (Nothing, _) -> Left ["Found orphan list values table " ++ valuesName] migrateList _ t = fail $ "migrateList: expected DbList, got " ++ show t  getAlters :: MigrationPack m@@ -267,9 +272,10 @@       Just s -> [UpdateValue s, NotNull]     _ -> []   modType = if compareTypes type1 type2 then [] else [Type type2]-  modDef = if def1 == def2-    then []-    else [maybe NoDefault Default def2]+  modDef = case (def1, def2) of+    (Nothing, Nothing) -> []+    (Just def1', Just def2') | compareDefaults def1' def2' -> []+    _ -> [maybe NoDefault Default def2]  -- from database, from datatype migrateUniq :: UniqueDef' -> UniqueDef' -> [AlterTable]@@ -290,39 +296,36 @@       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+  let dels = concatMap (mkDeletes escape) $ constrParams constr   (triggerExisted, delTrigger) <- migTriggerOnDelete schema cName dels   updTriggers <- liftM (concatMap snd) $ migTriggerOnUpdate schema cName dels   -  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]]-                      )--      uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' (Just uName) uType (map colName $ fst $ mkColumns' cols)) $ constrUniques constr--      (addInCreate, addInAlters) = addUniquesReferences uniques refs'-      autoKey = fmap (\x -> escape x ++ " " ++ mainRef) $ constrAutoKeyName constr-      items = maybeToList autoKey ++ map showColumn columns ++ addInCreate-      addTable = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")"+  let (columns, refs) = foldr mkColumns [] &&& concatMap mkReferences $ constrParams constr+      (expectedTableStructure, (addTable, addInAlters)) = case constrAutoKeyName constr of+        Nothing -> (TableInfo columns uniques (mkRefs refs), f [] columns uniques refs)+        Just keyName -> let keyColumn = Column keyName False DbAutoKey Nothing +                        in if simple+          then (TableInfo (keyColumn:columns) (uniques ++ [UniqueDef' Nothing UniquePrimary [keyName]]) (mkRefs refs)+               , f [escape keyName ++ " " ++ primaryKeyTypeName] columns uniques refs)+          else let columns' = keyColumn:columns+                   refs' = refs ++ [Reference schema name [(keyName, mainTableId)] (Just Cascade) Nothing]+                   uniques' = uniques ++ [UniqueDef' Nothing UniqueConstraint [keyName]]+               in (TableInfo columns' uniques' (mkRefs refs'), f [] columns' uniques' refs')+      uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' (Just uName) uType (map colName $ foldr mkColumns [] cols)) $ constrUniques constr+      f autoKey cols uniqs refs' = (addTable', addInAlters') where+        (addInCreate, addInAlters') = addUniquesReferences uniqs refs'+        items = autoKey ++ map showColumn cols ++ addInCreate+        addTable' = "CREATE TABLE " ++ tableName escape e constr ++ " (" ++ intercalate ", " items ++ ")"+      mkRefs = map (\r -> (Nothing, r)) --- change primary key and columns depending on isSimple-      expectedTableStructure = TableInfo columns' uniques' (map (\r -> (Nothing, r)) refs')       (migErrs, constrExisted, mig) = case tableStructure of-        Right Nothing  -> let+        Nothing -> let           rest = AlterTable schema cName addTable expectedTableStructure expectedTableStructure addInAlters           in ([], False, [AddTable addTable, rest])-        Right (Just oldTableStructure) -> let+        Just oldTableStructure -> let           alters = getAlters migPack oldTableStructure expectedTableStructure           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       allErrs = if constrExisted == triggerExisted || (constrExisted && null dels)         then migErrs@@ -333,13 +336,10 @@  -- on delete removes all ephemeral data -- returns column name and delete statement for the referenced table-mkDeletes :: MigrationPack m -> [Column] -> [(String, String)]-mkDeletes MigrationPack{..} columns = mapMaybe delField columns where-  delField (Column name _ t _) = fmap delStatement $ ephemeralName t where-    delStatement ref = (name, "DELETE FROM " ++ escape ref ++ " WHERE id=old." ++ escape name ++ ";")-  ephemeralName (DbMaybe x) = ephemeralName x-  ephemeralName (DbList name _) = Just name-  ephemeralName _ = Nothing+mkDeletes :: (String -> String) -> (String, DbType) -> [(String, String)]+mkDeletes esc = concat . traverseDbType f where+  f (DbList ref _) [col] = [(col, "DELETE FROM " ++ esc ref ++ " WHERE id=old." ++ esc col ++ ";")]+  f _ _ = []  showReferenceAction :: ReferenceActionType -> String showReferenceAction NoAction = "NO ACTION"@@ -357,7 +357,7 @@   "SET DEFAULT" -> Just SetDefault   _ -> Nothing -class SchemaAnalyzer m where+class Monad m => SchemaAnalyzer m where   listTables :: Maybe String -- ^ Schema name              -> m [String]   listTableTriggers :: Maybe String -- ^ Schema name@@ -365,7 +365,7 @@                     -> m [String]   analyzeTable :: Maybe String -- ^ Schema name                -> String -- ^ Table name-               -> m (Either [String] (Maybe TableInfo))+               -> m (Maybe TableInfo)   analyzeTrigger :: Maybe String -- ^ Schema name                  -> String -- ^ Trigger name                  -> m (Maybe String)

@@ -46,7 +46,7 @@         Nothing -> return Nothing     else do       let query = "SELECT discr FROM " <> mainTableName escape e <> " WHERE id=?"-      x <- queryFunc query [DbInt32] [toPrimitivePersistValue proxy k] id+      x <- queryFunc query [dbInt64] [toPrimitivePersistValue proxy k] id       case x of         Just [discr] -> do           let constructorNum = fromPrimitivePersistValue proxy discr@@ -60,7 +60,7 @@         Just x' -> fail $ "Unexpected number of columns returned: " ++ show x'         Nothing -> return Nothing -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)+select :: forall m db r v c opts . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v 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@@ -79,7 +79,7 @@   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'   doSelectQuery = queryFunc query types binds $ mapAllRows $ liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy cNum:)   binds = maybe id getValues cond' $ limps-  cNum = phantomConstrNum (undefined :: c a)+  cNum = entityConstrNum (undefined :: Proxy v) (undefined :: c a)   constr = constructors e !! cNum   types = getConstructorTypes constr @@ -91,12 +91,12 @@       constr = head $ constructors e       fields = maybe id (\key cont -> key <> fromChar ',' <> cont) (constrId escape constr) $ renderFields escape (constrParams constr)       query = "SELECT " <> fields <> " FROM " <> tableName escape e constr-      types = maybe id (const $ (DbInt64:)) (constrId escape constr) $ getConstructorTypes 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 query = "SELECT " <> fields <> " FROM " <> tableName escape e constr-        let types = DbInt64:getConstructorTypes constr+        let types = dbInt64:getConstructorTypes constr         queryFunc query types [] $ mapAllRows $ mkEntity proxy cNum   e = entityDef (undefined :: v)   proxy = undefined :: Proxy (PhantomDb m)@@ -117,7 +117,7 @@     Just xs -> liftM (Just . fst) $ fromEntityPersistValues $ PersistInt64 0:xs     Nothing -> return Nothing -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)+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, EntityConstr v 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@@ -137,22 +137,22 @@   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'   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 . exprType) [] $ chains where+  constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)+  types = map 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 db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c)+count :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v 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)       proxy = undefined :: Proxy (PhantomDb m)       cond' = renderCond' cond-      constr = constructors e !! phantomConstrNum (undefined :: c a)+      constr = constructors e !! entityConstrNum (undefined :: Proxy v) (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+  x <- queryFunc query [dbInt64] (maybe [] (flip getValues []) cond') id   case x of     Just [num] -> return $ fromPrimitivePersistValue proxy num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)@@ -175,7 +175,7 @@     then execFunc updateQuery (tail vals ++ [toPrimitivePersistValue proxy k])     else do       let query = "SELECT discr FROM " <> mainTableName escape e <> " WHERE id=?"-      x <- queryFunc query [DbInt32] [toPrimitivePersistValue proxy k] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))+      x <- queryFunc query [dbInt64] [toPrimitivePersistValue proxy k] (id >=> return . fmap (fromPrimitivePersistValue proxy . head))       case x of         Just discr -> do           let cName = tableName escape e constr@@ -194,24 +194,24 @@               execFunc updateDiscrQuery [head vals, toPrimitivePersistValue proxy k]         Nothing -> return () -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)+update :: forall m db r v c . (SqlDb db, QueryRaw db ~ Snippet db, db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v 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)   case renderUpdates escape upds of     Just upds' -> do       let cond' = renderCond' cond-          constr = constructors e !! phantomConstrNum (undefined :: c a)+          constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)           query = "UPDATE " <> tableName escape e constr <> " SET " <> whereClause where           whereClause = maybe (getQuery upds') (\c -> getQuery upds' <> " WHERE " <> getQuery c) cond'       execFunc query (getValues upds' <> maybe mempty getValues cond' $ [])     Nothing -> return () -delete :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, Constructor c)+delete :: forall m db r v c . (db ~ PhantomDb m, r ~ RestrictionHolder v c, PersistBackend m, PersistEntity v, EntityConstr v 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 = constructors e !! phantomConstrNum (undefined :: c a)+  constr = constructors e !! entityConstrNum (undefined :: Proxy v) (undefined :: c a)   cond' = renderCond' cond   whereClause = maybe "" (\c -> " WHERE " <> getQuery c) cond'   query = if isSimple (constructors e)@@ -233,7 +233,7 @@     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+      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]@@ -257,7 +257,7 @@   let e = entityDef (undefined :: v)       proxy = undefined :: Proxy (PhantomDb m)       query = "SELECT COUNT(*) FROM " <> mainTableName escape e-  x <- queryFunc query [DbInt64] [] id+  x <- queryFunc query [dbInt64] [] id   case x of     Just [num] -> return $ fromPrimitivePersistValue proxy num     Just xs -> fail $ "requested 1 column, returned " ++ show (length xs)@@ -275,20 +275,14 @@       -- 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+  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--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+getConstructorTypes = map snd . constrParams where  constrId :: (Utf8 -> Utf8) -> ConstructorDef -> Maybe Utf8 constrId escape = fmap (escape . fromString) . constrAutoKeyName@@ -300,3 +294,6 @@  toEntityPersistValues' :: (PersistBackend m, PersistEntity v) => v -> m [PersistValue] toEntityPersistValues' = liftM ($ []) . toEntityPersistValues++dbInt64 :: DbType+dbInt64 = DbTypePrimitive DbInt64 False Nothing Nothing

@@ -160,6 +160,7 @@     [] -> Nothing     [a] -> Just a     _ -> error "renderCond: cannot render CondRaw with many elements"+  go CondEmpty _ = Nothing   notP = 35   andP = 30   orP = 20@@ -229,9 +230,7 @@ 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+    DbEmbedded emb _ -> handleEmb emb     _            -> esc fullName : acc   fullName = fromString fname   handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts@@ -240,9 +239,7 @@ 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+    DbEmbedded emb _ -> handleEmb emb     _            -> esc fullName : acc   fullName = prefix <> fromChar delim <> fromString fname   handleEmb (EmbeddedDef False ts) = foldr (flattenP esc fullName) acc ts

@@ -3,6 +3,7 @@ -- | This module has common SQL functions and operators which are supported in the most SQL databases module Database.Groundhog.Generic.Sql.Functions     ( like+    , notLike     , in_     , notIn_     , lower@@ -25,6 +26,9 @@  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++notLike :: (SqlDb db, QueryRaw db ~ Snippet db, ExpressionOf db r a String) => a -> String -> Cond db r+notLike a b = CondRaw $ operator 40 " NOT 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]

@@ -238,109 +238,109 @@   persistName _ = "ByteString"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbBlob+  dbType _ = DbTypePrimitive DbBlob False Nothing Nothing  instance PersistField String where   persistName _ = "String"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbString+  dbType _ = DbTypePrimitive DbString False Nothing Nothing  instance PersistField T.Text where   persistName _ = "Text"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbString+  dbType _ = DbTypePrimitive DbString False Nothing Nothing  instance PersistField Int where   persistName _ = "Int"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType a = if bitSize a == 32 then DbInt32 else DbInt64+  dbType a = DbTypePrimitive (if bitSize a == 32 then DbInt32 else DbInt64) False Nothing Nothing  instance PersistField Int8 where   persistName _ = "Int8"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt32+  dbType _ = DbTypePrimitive DbInt32 False Nothing Nothing  instance PersistField Int16 where   persistName _ = "Int16"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt32+  dbType _ = DbTypePrimitive DbInt32 False Nothing Nothing  instance PersistField Int32 where   persistName _ = "Int32"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt32+  dbType _ = DbTypePrimitive DbInt32 False Nothing Nothing  instance PersistField Int64 where   persistName _ = "Int64"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt64+  dbType _ = DbTypePrimitive DbInt64 False Nothing Nothing  instance PersistField Word8 where   persistName _ = "Word8"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt32+  dbType _ = DbTypePrimitive DbInt32 False Nothing Nothing  instance PersistField Word16 where   persistName _ = "Word16"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt32+  dbType _ = DbTypePrimitive DbInt32 False Nothing Nothing  instance PersistField Word32 where   persistName _ = "Word32"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt64+  dbType _ = DbTypePrimitive DbInt64 False Nothing Nothing  instance PersistField Word64 where   persistName _ = "Word64"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbInt64+  dbType _ = DbTypePrimitive DbInt64 False Nothing Nothing  instance PersistField Double where   persistName _ = "Double"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbReal+  dbType _ = DbTypePrimitive DbReal False Nothing Nothing  instance PersistField Bool where   persistName _ = "Bool"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbBool+  dbType _ = DbTypePrimitive DbBool False Nothing Nothing  instance PersistField Day where   persistName _ = "Day"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbDay+  dbType _ = DbTypePrimitive DbDay False Nothing Nothing  instance PersistField TimeOfDay where   persistName _ = "TimeOfDay"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbTime+  dbType _ = DbTypePrimitive DbTime False Nothing Nothing  instance PersistField UTCTime where   persistName _ = "UTCTime"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbDayTime+  dbType _ = DbTypePrimitive DbDayTime False Nothing Nothing  instance PersistField ZonedTime where   persistName _ = "ZonedTime"   toPersistValues = primToPersistValue   fromPersistValues = primFromPersistValue-  dbType _ = DbDayTimeZoned+  dbType _ = DbTypePrimitive DbDayTimeZoned False Nothing Nothing  -- There is a weird bug in GHC 7.4.1 which causes program to hang. See ticket 7126. -- instance (PersistField a, NeverNull a) => PersistField (Maybe a) where -- OK@@ -352,7 +352,9 @@   fromPersistValues [] = fail "fromPersistValues Maybe: empty list"   fromPersistValues (PersistNull:xs) = return (Nothing, xs)   fromPersistValues xs = fromPersistValues xs >>= \(x, xs') -> return (Just x, xs')-  dbType a = DbMaybe $ dbType ((undefined :: Maybe a -> a) a)+  dbType a = case dbType ((undefined :: Maybe a -> a) a) of+    DbTypePrimitive t _ def ref -> DbTypePrimitive t True def ref+    t -> error $ "dbType " ++ persistName a ++ ": expected DbTypePrimitive, got " ++ show t  instance (PersistField a) => PersistField [a] where   persistName a = "List" ++ delim : delim : persistName ((undefined :: [] a -> a) a)@@ -365,7 +367,7 @@   persistName _ = "Unit" ++ [delim]   toPersistValues _ = return id   fromPersistValues xs = return ((), xs)-  dbType _ = DbEmbedded $ EmbeddedDef False []+  dbType _ = DbEmbedded (EmbeddedDef False []) Nothing  instance (PersistField a, PersistField b) => PersistField (a, b) where   persistName a = "Tuple2" ++ delim : delim : persistName ((undefined :: (a, b) -> a) a) ++ delim : persistName ((undefined :: (a, b) -> b) a)@@ -377,7 +379,7 @@     (a, rest0) <- fromPersistValues xs     (b, rest1) <- fromPersistValues rest0     return ((a, b), rest1)-  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b) -> a) a)), ("val1", dbType ((undefined :: (a, b) -> b) a))]+  dbType a = DbEmbedded (EmbeddedDef False [("val0", dbType ((undefined :: (a, b) -> a) a)), ("val1", dbType ((undefined :: (a, b) -> b) a))]) Nothing    instance (PersistField a, PersistField b, PersistField c) => PersistField (a, b, c) where   persistName a = "Tuple3" ++ delim : delim : persistName ((undefined :: (a, b, c) -> a) a) ++ delim : persistName ((undefined :: (a, b, c) -> b) a) ++ delim : persistName ((undefined :: (a, b, c) -> c) a)@@ -391,7 +393,7 @@     (b, rest1) <- fromPersistValues rest0     (c, rest2) <- fromPersistValues rest1     return ((a, b, c), rest2)-  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c) -> a) a)), ("val1", dbType ((undefined :: (a, b, c) -> b) a)), ("val2", dbType ((undefined :: (a, b, c) -> c) a))]+  dbType a = DbEmbedded (EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c) -> a) a)), ("val1", dbType ((undefined :: (a, b, c) -> b) a)), ("val2", dbType ((undefined :: (a, b, c) -> c) a))]) Nothing    instance (PersistField a, PersistField b, PersistField c, PersistField d) => PersistField (a, b, c, d) where   persistName a = "Tuple4" ++ delim : delim : persistName ((undefined :: (a, b, c, d) -> a) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> b) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> c) a) ++ delim : persistName ((undefined :: (a, b, c, d) -> d) a)@@ -407,7 +409,7 @@     (c, rest2) <- fromPersistValues rest1     (d, rest3) <- fromPersistValues rest2     return ((a, b, c, d), rest3)-  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c, d) -> a) a)), ("val1", dbType ((undefined :: (a, b, c, d) -> b) a)), ("val2", dbType ((undefined :: (a, b, c, d) -> c) a)), ("val3", dbType ((undefined :: (a, b, c, d) -> d) a))]+  dbType a = DbEmbedded (EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c, d) -> a) a)), ("val1", dbType ((undefined :: (a, b, c, d) -> b) a)), ("val2", dbType ((undefined :: (a, b, c, d) -> c) a)), ("val3", dbType ((undefined :: (a, b, c, d) -> d) a))]) Nothing    instance (PersistField a, PersistField b, PersistField c, PersistField d, PersistField e) => PersistField (a, b, c, d, e) where   persistName a = "Tuple5" ++ delim : delim : persistName ((undefined :: (a, b, c, d, e) -> a) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> b) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> c) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> d) a) ++ delim : persistName ((undefined :: (a, b, c, d, e) -> e) a)@@ -425,7 +427,7 @@     (d, rest3) <- fromPersistValues rest2     (e, rest4) <- fromPersistValues rest3     return ((a, b, c, d, e), rest4)-  dbType a = DbEmbedded $ EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c, d, e) -> a) a)), ("val1", dbType ((undefined :: (a, b, c, d, e) -> b) a)), ("val2", dbType ((undefined :: (a, b, c, d, e) -> c) a)), ("val3", dbType ((undefined :: (a, b, c, d, e) -> d) a)), ("val4", dbType ((undefined :: (a, b, c, d, e) -> e) a))]+  dbType a = DbEmbedded (EmbeddedDef False [("val0", dbType ((undefined :: (a, b, c, d, e) -> a) a)), ("val1", dbType ((undefined :: (a, b, c, d, e) -> b) a)), ("val2", dbType ((undefined :: (a, b, c, d, e) -> c) a)), ("val3", dbType ((undefined :: (a, b, c, d, e) -> d) a)), ("val4", dbType ((undefined :: (a, b, c, d, e) -> e) a))]) Nothing  instance (DbDescriptor db, PersistEntity v) => PersistField (KeyForBackend db v) where   persistName a = "KeyForBackend" ++ delim : persistName ((undefined :: KeyForBackend db v -> v) a)@@ -433,11 +435,11 @@   fromPersistValues = primFromPersistValue   dbType a = dbType ((undefined :: KeyForBackend db v -> v) a) -instance (PersistEntity v, Constructor c, PersistField a) => Projection (Field v c a) db (RestrictionHolder v c) a where+instance (EntityConstr v 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) db (RestrictionHolder v c) a where+instance (EntityConstr v c, PersistField a) => Projection (SubField v c a) db (RestrictionHolder v c) a where   projectionExprs f = (ExprField (fieldChain f):)   projectionResult _ = fromPersistValues @@ -445,18 +447,20 @@   projectionExprs e = (ExprRaw e:)   projectionResult _ = fromPersistValues -instance (PersistEntity v, Constructor c, a ~ AutoKey v) => Projection (AutoKeyField v c) db (RestrictionHolder v c) a where+instance (EntityConstr v c, a ~ AutoKey v) => Projection (AutoKeyField v c) db (RestrictionHolder v c) a where   projectionExprs f = (ExprField (fieldChain f):)   projectionResult _ = fromPersistValues -instance (PersistEntity v, Constructor c) => Projection (c (ConstructorMarker v)) db (RestrictionHolder v c) v where+instance EntityConstr v 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)+    cNum = entityConstrNum ((undefined :: c (ConstructorMarker v) -> Proxy v) c) c+    constr = constructors e !! cNum+  projectionResult c xs = toSinglePersistValue cNum >>= \cNum' -> fromEntityPersistValues (cNum':xs) where+    cNum = entityConstrNum ((undefined :: c (ConstructorMarker v) -> Proxy v) c) c -instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), r ~ RestrictionHolder v (UniqueConstr k))+instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), r ~ RestrictionHolder v c)       => Projection (u (UniqueMarker v)) db r k where   projectionExprs u = ((map ExprField chains)++) where     UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)@@ -498,29 +502,39 @@     (e, rest4) <- projectionResult e' rest3     return ((a, b, c, d, e), rest4) -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 (EntityConstr v c, Projection (AutoKeyField v c) db r a') => Assignable (AutoKeyField v c) db r a'+instance (EntityConstr v c, Projection (SubField v c a) db r a') => Assignable (SubField v c a) db r a'+instance (EntityConstr v 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, a ~ AutoKey v) => FieldLike (AutoKeyField v c) db (RestrictionHolder v c) a where+instance (EntityConstr v c, a ~ AutoKey v) => FieldLike (AutoKeyField v c) db (RestrictionHolder v c) a where   fieldChain a = chain where     chain = ((name, dbType k), [])     -- if it is Nothing, the name would not be used because the type will be () with no columns     name = maybe "will_be_ignored" id $ constrAutoKeyName $ constructors e !! cNum     k = (undefined :: AutoKeyField v c -> AutoKey v) a+     e = entityDef ((undefined :: AutoKeyField v c -> v) a)-    cNum = phantomConstrNum ((undefined :: AutoKeyField v c -> c (ConstructorMarker v)) a)+    cNum = entityConstrNum ((undefined :: AutoKeyField v c -> Proxy v) a) ((undefined :: AutoKeyField v c -> c (ConstructorMarker v)) a) -instance (PersistEntity v, Constructor c, PersistField a) => FieldLike (SubField v c a) db (RestrictionHolder v c) a where+instance (EntityConstr v c, PersistField a) => FieldLike (SubField v c a) db (RestrictionHolder v c) a where   fieldChain (SubField a) = a -instance (PersistEntity v, Constructor c, PersistField a) => FieldLike (Field v c a) db (RestrictionHolder v c) a where+instance (EntityConstr v c, PersistField a) => FieldLike (Field v c a) db (RestrictionHolder v c) a where   fieldChain = entityFieldChain -instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), r ~ RestrictionHolder v (UniqueConstr k))+instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), r ~ RestrictionHolder v c)       => FieldLike (u (UniqueMarker v)) db r k 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), [])+    chain = (("will_be_ignored", DbEmbedded (EmbeddedDef True uFields) Nothing), [])     constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u))++instance (PersistEntity v, EntityConstr' (IsSumType v) c) => EntityConstr v c where+  entityConstrNum v = entityConstrNum' $ (undefined :: Proxy v -> IsSumType v) v+class EntityConstr' flag c where+  entityConstrNum' :: flag -> c (a :: * -> *) -> Int+instance EntityConstr' HFalse c where+  entityConstrNum' _ _ = 0+instance Constructor c => EntityConstr' HTrue c where+  entityConstrNum' _ = phantomConstrNum

@@ -1,36 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, StandaloneDeriving #-}-import Control.Monad.IO.Class (liftIO)-import Database.Groundhog.TH-import Database.Groundhog.Sqlite--data Customer = Customer {customerName :: String, phone :: String} deriving Show-data Product = Product {productName :: String, quantity :: Int, customer :: DefaultKey Customer}-deriving instance Show Product--mkPersist defaultCodegenConfig [groundhog|-- entity: Customer               # Name of the datatype-  constructors:-    - name: Customer-      fields:-        - name: customerName-          dbName: name           # Set column name to "name" instead of "customerName"-      uniques:-        - name: NameConstraint-          fields: [customerName] # Inline format of list-- entity: Product-|]--main = withSqliteConn "mydb.sqlite" $ runDbConn $ do-  runMigration defaultMigrationLogger $ do-    migrate (undefined :: Customer)-    migrate (undefined :: Product)-  johnKey <- insert $ Customer "John Doe" "0123456789"-  get johnKey >>= liftIO . print-  insert $ Product "Apples" 5 johnKey-  insert $ Product "Melon" 3 johnKey-  janeKey <- insert $ Customer "Jane Doe" "987654321"-  insert $ Product "Oranges" 4 janeKey-  -- bonus melon for all large melon orders. The values used in expressions should have known type, so literal 5 is annotated.-  update [QuantityField =. toArith QuantityField + 1] (ProductNameField ==. "Melon" &&. QuantityField >. (5 :: Int))-  productsForJohn <- select $ (CustomerField ==. johnKey) `orderBy` [Asc ProductNameField]-  liftIO $ putStrLn $ "Products for John: " ++ show productsForJohn

@@ -1,56 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-}-import Control.Monad.IO.Class (liftIO)-import Data.ByteString.Char8 (unpack)-import Database.Groundhog.Core-import Database.Groundhog.Generic-import Database.Groundhog.TH-import Database.Groundhog.Postgresql--data Point = Point { pointX :: Int, pointY :: Int } deriving Show---- PostgreSQL keeps point in format "(x,y)". This instance relies on the correspondence between Haskell tuple format and PostgreSQL point format.-instance PrimitivePersistField Point where-  toPrimitivePersistValue _ (Point x y) = PersistString $ show (x, y)-  fromPrimitivePersistValue _ (PersistString a) = let (x, y) = read a in Point x y-  fromPrimitivePersistValue _ (PersistByteString a) = let (x, y) = read (unpack a) in Point x y--instance PersistField Point where-  persistName _ = "Point"-  toPersistValues = primToPersistValue-  fromPersistValues = primFromPersistValue-  dbType _ = DbOther $ OtherTypeDef $ const "point"---- These two instances of superclasses are useful but not necessary. They are like Functor and Applicative instances when you implement a Monad.-instance SinglePersistField Point where-  toSinglePersistValue = primToSinglePersistValue-  fromSinglePersistValue = primFromSinglePersistValue--instance PurePersistField Point where-  toPurePersistValues = primToPurePersistValues-  fromPurePersistValues = primFromPurePersistValues--data MobilePhone = MobilePhone {number :: String, prepaidMoney :: String, location :: Point, ipAddress :: String} deriving Show--mkPersist defaultCodegenConfig [groundhog|-- entity: MobilePhone-  constructors:-    - name: MobilePhone-      fields:-        - name: number-          type: varchar(13)-        - name: prepaidMoney-          type: money-# We don't need to put "typeName: point" for location because the dbType definition already has the required type-        - name: ipAddress-          type: inet-|]--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-  -- This will output the mobile phone data with money rounded to two fractional digits-  get k >>= liftIO . print-  liftIO $ putStrLn "This insert will make PostgreSQL throw an exception:"-  -- PGRES_FATAL_ERROR: ERROR:  value too long for type character varying(13)-  insert $ phone {number = "Phone number is too long now"}

@@ -1,60 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-}-import Control.Monad.IO.Class (liftIO)-import Database.Groundhog.TH-import Database.Groundhog.Sqlite--data Company = Company {name :: String, producedSkynetAndTerminator :: (Bool, Bool), headquarter :: Address, dataCentre :: Address, salesOffice :: Address} deriving (Eq, Show)-data Address = Address {city :: String, zipCode :: String, street :: String} deriving (Eq, Show)--mkPersist defaultCodegenConfig [groundhog|-definitions:-  - entity: Company-    constructors:-      - name: Company-        fields:-          - name: producedSkynetAndTerminator-            embeddedType:-              - name: val0-                dbName: producedSkynet-              - name: val1-                dbName: producedTerminator-          - name: headquarter-            embeddedType:               # If a field has an embedded type you can access its subfields. If you do it, the database columns will match with the embedded dbNames (no prefixing).-              - name: city              # Just a regular list of fields. However, note that you should use default dbNames of embedded-                dbName: hq_city-              - name: zip_code          # Here we use embedded dbName (zip_code) which differs from the name used in Address definition (zipCode) for accessing the field.-                dbName: hq_zipcode-              - name: street-                dbName: hq_street-          - name: dataCentre-            embeddedType:               # Similar declaration, but using another syntax for YAML objects-              - {name: city, dbName: dc_city}-              - {name: zip_code, dbName: dc_zipcode}-              - {name: street, dbName: dc_street}-                                        # Property embeddedType of salesOffice field is not mentioned, so the corresponding table columns will have names prefixed with salesOffice (salesOffice#city, salesOffice#zip_code, salesOffice#street)-  - embedded: Address-    dbName: Address                     # This name is used only to set polymorphic part of name of its container. E.g, persistName (a :: SomeData Address) = "SomeData#Address"-    fields:                             # The syntax is the same as for constructor fields. Nested embedded types are allowed.-      - name: city                      # This line does nothing and can be omitted. Default settings for city are not changed.-      - name: zipCode-        dbName: zip_code                # Change column name.-        exprName: ZipCodeSelector       # Set the default name explicitly-                                        # Street is not mentioned so it will have default settings.- |]--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-  k <- insert company-  -- compare embedded data fields as a whole and compare their subfields individually-  select (DataCentreField ==. HeadquarterField &&. DataCentreField ~> ZipCodeSelector ==. HeadquarterField ~> ZipCodeSelector) >>= liftIO . print-  -- after the Cyberdyne headquarter was destroyed by John Connor and T-800, the Skynet development was continued by Cyber Research Systems affiliated with Pentagon-  let newAddress = Address "Washington" "20301" "1400 Defense Pentagon"-  -- compare fields with an embedded value as a whole and update embedded field with a value-  update [NameField =. "Cyber Research Systems", HeadquarterField =. newAddress] (NameField ==. "Cyberdyne Systems" &&. HeadquarterField ==. address)-  -- update embedded field with another field as a whole. Separate subfields can be accessed individually for update via ~> as in the select above-  update [DataCentreField =. HeadquarterField, SalesOfficeField =. HeadquarterField] (NameField ==. "Cyber Research Systems" &&. HeadquarterField ==. newAddress)-  -- eventually the skynet was developed. To access the elements of tuple we use predefined selectors. In Tuple2_0Selector 2 is arity of the tuple, 0 is number of element in it-  update [ProducedSkynetAndTerminatorField ~> Tuple2_0Selector =. True] (AutoKeyField ==. k)-  select (HeadquarterField ~> ZipCodeSelector ==. "20301") >>= liftIO . print

@@ -1,77 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, StandaloneDeriving #-}
-import Control.Monad
-import Control.Monad.IO.Class (liftIO)
-import Database.Groundhog.TH
-import Database.Groundhog.Sqlite
-
-data Artist = Artist { artistName :: String } deriving (Eq, Show)
-data Album  = Album  { albumName :: String} deriving (Eq, Show)
--- We cannot use regular deriving because when it works, the Key Eq and Show instances for (Key Album BackendSpecific) are not created yet
-data Track  = Track  { albumTrack :: Key Album BackendSpecific, trackName :: String }
-deriving instance Eq Track
-deriving instance Show Track
-
-mkPersist defaultCodegenConfig [groundhog|
-definitions:
-  - entity: Artist
-    autoKey:
-      constrName: AutoKey
-      default: false # Defines if this key is used when an entity is stored directly, for example, data Ref = Ref Artist
-    keys:
-      - name: ArtistName
-        default: true
-    constructors:
-      - name: Artist
-        uniques:
-          - name: ArtistName
-            # Optional parameter type can be constraint (by default), index, or primary
-            type: constraint
-            fields: [artistName]
-  - entity: Album
-  - entity: Track
-    constructors:
-      - name: Track
-        fields:
-          - name: albumTrack
-  # Configure actions on parent table changes
-            onDelete: cascade
-            onUpdate: restrict
-|]
-
--- Many-to-many relation. It is defined here because ArtistName is available only after the the definitions for Artist are created
-data ArtistAlbum = ArtistAlbum {artist :: Key Artist (Unique ArtistName), album :: Key Album BackendSpecific }
-deriving instance Eq ArtistAlbum
-deriving instance Show ArtistAlbum
-
-mkPersist defaultCodegenConfig [groundhog|
-definitions:
-  - entity: ArtistAlbum
-    autoKey: null # Disable creation of the autoincrement integer key
-    keys:
-      - name: ArtistAlbumKey
-        default: true
-    constructors:
-      - name: ArtistAlbum
-        uniques:
-          - name: ArtistAlbumKey
-            fields: [artist, album]
-|]
-
-main :: IO ()
-main = withSqliteConn ":memory:" $ runDbConn $ do
-  let artists = [Artist "John Lennon", Artist "George Harrison"]
-      imagineAlbum = Album "Imagine"
-  runMigration defaultMigrationLogger $ do
-    migrate (undefined :: ArtistAlbum)
-    migrate (undefined :: Track)
-  mapM_ insert artists
-
-  imagineKey <- insert imagineAlbum
-  let tracks = map (Track imagineKey) ["Imagine", "Crippled Inside", "Jealous Guy", "It's So Hard", "I Don't Want to Be a Soldier, Mama, I Don't Want to Die", "Gimme Some Truth", "Oh My Love", "How Do You Sleep?", "How?", "Oh Yoko!"]
-  mapM_ insert tracks
-  mapM_ (\artist -> insert $ ArtistAlbum (extractUnique artist) imagineKey) artists
-  -- 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` [Desc AutoKeyField] `limitTo` 3
-  liftIO $ print tracks'

@@ -1,47 +0,0 @@-{-# 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,35 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-}-import Control.Monad-import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString.Char8 as BS-import Database.Groundhog.TH-import Database.Groundhog.Sqlite--data User = User {name :: String, phoneNumber :: (String, String), bigAvatar :: BS.ByteString} deriving (Eq, Show)--mkPersist defaultCodegenConfig [groundhog|-definitions:-  - entity: User-    keys:-      - name: unique_name-    constructors:-      - name: User-        uniques:-          - name: unique_name-            fields: [name]-|]--main :: IO ()-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 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.-  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

@@ -1,36 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-}-import Control.Monad (liftM, (>=>))-import Control.Monad.IO.Class (liftIO)-import Database.Groundhog.Core (PersistValue, PersistField(..), PrimitivePersistField(..), RowPopper, PersistEntity(..))-import Database.Groundhog.Generic (mapAllRows, phantomDb)-import Database.Groundhog.TH-import Database.Groundhog.Sqlite--data SomeData = SomeData Int (Int, String) deriving Show--mkPersist defaultCodegenConfig [groundhog|-- entity: SomeData-|]--main = withSqliteConn ":memory:" $ runDbConn $ do-  runMigration defaultMigrationLogger $ migrate (undefined :: SomeData)-  k1 <- insert $ SomeData 1 (2, "abc")-  k2 <- insert $ SomeData 10 (20, "def")-  proxy <- phantomDb-  -  -- PersistField instance for PersistEntity expects to receive its id, not values contained in data.-  -- So here we cannot use fromPersistValues to get data.-  xs1 <- queryRaw False "SELECT \"SomeData0\", \"someData1#val0\", \"someData1#val1\" FROM \"SomeData\" WHERE \"id\" = ? OR \"id\" = ?" [toPrimitivePersistValue proxy k1, toPrimitivePersistValue proxy k2] $ mapAllRows (liftM fst . fromPersistValues)-  liftIO $ print (xs1 :: [(Int, Int, String)])-  -  -- it will run 1 + N select queries to get data by id.-  xs2 <- queryRaw False "SELECT \"id\" FROM \"SomeData\" ORDER BY \"someData1#val0\" DESC" [] $ mapAllRows (liftM fst . fromPersistValues)-  liftIO $ print (xs2 :: [SomeData])-  -  -- function fromEntityPersistValues from PersistEntity expects constructor number (they start from 0) and the data contained in it.-  xs3 <- queryRaw False "SELECT \"SomeData0\", \"someData1#val0\", \"someData1#val1\" FROM \"SomeData\" WHERE \"id\" = ? OR \"id\" = ?" [toPrimitivePersistValue proxy k1, toPrimitivePersistValue proxy k2] $ mapAllRows (liftM fst . fromEntityPersistValues . (toPrimitivePersistValue proxy (0 :: Int):))-  liftIO $ print (xs3 :: [SomeData])-  -  -- the queries not supported by groundhog API may be run via raw SQL. If number of columns is too big (there are no instances PersistFields for tuples with more than 5 elements) you can nest tuples-  xs4 <- queryRaw False "SELECT s1.\"id\", s1.\"someData1#val1\", s2.\"id\", s2.\"someData1#val1\" FROM \"SomeData\" s1 INNER JOIN \"SomeData\" s2 ON s1.\"id\" <= s2.\"id\"" [] $ mapAllRows (liftM fst . fromPersistValues)-  liftIO $ print (xs4 :: [((String, String), (String, String))])

@@ -1,30 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-}-import Control.Monad.IO.Class (liftIO)-import Database.Groundhog.TH-import Database.Groundhog.Sqlite--data Shape = Circle { radius :: Double }-           | Triangle { side1 :: Double, side2 :: Double, angle :: Double } deriving Show--mkPersist defaultCodegenConfig [groundhog|-- entity: Shape-  constructors:                         # Any constructors can be adjusted in this list. The order is not important.-    - name: Triangle                    # This declaration just repeats some of the default values and can be removed.-      exprName: TriangleConstructor     # Just as default.-    - name: Circle-      fields:-        - name: radius-          exprName: CircleRadius        # The default value defined by naming style was RadiusField-|]--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-  k <- insert circle-  insert (Circle 10)-  let triangle = Triangle 3 4 (pi / 2)-  replace k triangle-  count (CircleRadius <. (11 :: Double)) >>= \c -> liftIO (putStrLn $ "Small circles: " ++ show c)-  shapes <- selectAll-  liftIO $ print (shapes :: [(AutoKey Shape, Shape)])

@@ -1,23 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, FlexibleInstances #-}-import Control.Monad.IO.Class (liftIO)-import Database.Groundhog.TH-import Database.Groundhog.TH.Settings-import Database.Groundhog.Sqlite--data Table = Create {select :: String, update :: Int, fubar :: String} deriving (Eq, Show)--mkPersist defaultCodegenConfig $ PersistDefinitions [-  Left $ PSEntityDef "Table" Nothing Nothing Nothing Nothing $ Just [-    PSConstructorDef "Create" Nothing Nothing Nothing (Just [-        PSFieldDef "select" (Just "SELECT") Nothing Nothing Nothing Nothing Nothing-      , PSFieldDef "fubar" (Just "BEGIN COMMIT") Nothing Nothing Nothing Nothing Nothing-      ])-      Nothing-    ]-  ]--main = withSqliteConn ":memory:" $ runDbConn $ do-  let table = Create "DROP" maxBound "DELETE"-  runMigration defaultMigrationLogger $ migrate table-  k <- insert table-  get k >>= liftIO . print

@@ -1,28 +1,28 @@ name:            groundhog-version:         0.3.1.1+version:         0.4.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com> maintainer:      Boris Lykah <lykahb@gmail.com> 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.+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, advanced expressions in queries, and much more. See examples folder on GitHub. category:        Database stability:       Non-stable cabal-version:   >= 1.6 build-type:      Simple--extra-source-files:  examples/*.hs+homepage:        http://github.com/lykahb/groundhog  library-    build-depends:   base                     >= 4         && < 5+    build-depends:   base                     >= 4       && < 5                    , bytestring               >= 0.9-                   , transformers             >= 0.2.1     && < 0.4+                   , transformers             >= 0.2.1                    , mtl                      >= 2.0                    , time                     >= 1.1.4-                   , text                     >= 0.8       && < 0.12-                   , blaze-builder            >= 0.3.0.0   && < 0.4+                   , text                     >= 0.8+                   , blaze-builder            >= 0.3.0.0                    , containers               >= 0.2-                   , monad-control            >= 0.3       && < 0.4+                   , monad-control            >= 0.3+                   , monad-logger             >= 0.3                    , transformers-base     exposed-modules: Database.Groundhog                      Database.Groundhog.Core