groundhog 0.3.0.1 → 0.3.1

raw patch · 11 files changed

+267/−145 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Database/Groundhog.hs +4/−40
• Database/Groundhog/Core.hs +8/−8
• Database/Groundhog/Expression.hs +3/−2
• Database/Groundhog/Generic.hs +28/−12
• Database/Groundhog/Instances.hs +173/−36
• examples/basic.hs +21/−23
• examples/dbSpecificTypes.hs +9/−0
• examples/keys.hs +17/−20
• examples/rawQueries.hs +1/−1
• examples/withoutQuasiQuotes.hs +2/−2
• groundhog.cabal +1/−1

@@ -1,50 +1,14 @@ -- | This module exports the most commonly used functions and datatypes. ----- The example below shows the most of the main features. See more examples in the examples directory.------ @---{-\# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances \#-}---import Control.Monad.IO.Class (liftIO)---import Database.Groundhog.TH---import Database.Groundhog.Sqlite------data Customer a = Customer {customerName :: String, remark :: a} deriving Show---data Product = Product {productName :: String, quantity :: Int, customer :: Customer String} deriving Show------'mkPersist' ('defaultCodegenConfig' {migrationFunction = Just \"migrateAll\"}) [groundhog|--- - entity: Customer---   constructors:---     - name: Customer---       uniques:---         - name: NameConstraint---           fields: [customerName]--- - entity: Product--- |]------main = withSqliteConn \":memory:\" $ runDbConn $ do---  -- Customer is also migrated because Product references it.---  -- It is possible to migrate schema for given type, e.g. migrate (undefined :: Customer String), or run migrateAll---  'runMigration' 'defaultMigrationLogger' migrateAll---  let john = Customer \"John Doe\" \"Phone: 01234567\"---  johnKey <- 'insert' john---  -- John is inserted only once because of the name constraint---  insert $ Product \"Apples\" 5 john---  insert $ Product \"Melon\" 2 john---  -- Groundhog prevents SQL injections. Quotes and other special symbols are safe.---  insert $ Product \"Melon\" 6 (Customer \"Jack Smith\" \"Don't let him pay by check\")---  -- 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---  liftIO $ putStrLn $ \"Products for John: \" ++ show productsForJohn---  -- Check bonus---  melon <- select $ (ProductNameField ==. \"Melon\") \`orderBy\` ['Desc' QuantityField]---  liftIO $ putStrLn $ \"Melon orders: \" ++ show melon--- @+-- See the @examples@ directory in the package archive or <http://github.com/lykahb/groundhog/tree/master/examples>.+ module Database.Groundhog (   -- * Main definitions     PersistBackend(..)   , DbPersist(..)   , Key+  , DefaultKey+  , AutoKey   , Unique   , BackendSpecific   , extractUnique

@@ -116,12 +116,12 @@ data Unique (u :: (* -> *) -> *) -- | Key marked with this type can have value for any backend data BackendSpecific--- | A phantom datatype to make instance head diffirent @c (ConstructorMarker, v)@+-- | A phantom datatype to make instance head diffirent @c (ConstructorMarker v)@ data ConstructorMarker v a--- | A phantom datatype to make instance head diffirent @u (UniqueMarker, v)@+-- | A phantom datatype to make instance head diffirent @u (UniqueMarker v)@ data UniqueMarker v a --- | A holder for DB type in backend-specific keys+-- | It allows to store autogenerated keys of one database in another data KeyForBackend db v = (DbDescriptor db, PersistEntity v) => KeyForBackend (AutoKeyType db)  data Proxy a@@ -265,7 +265,7 @@   insertByAll   :: PersistEntity v => v -> m (Either (AutoKey v) (AutoKey v))   -- | 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] \`limitBy\` 100@+  -- | 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))                 => opts -> m [v]   -- | Return a list of all records. Order is undefined. It is useful for datatypes with multiple constructors.@@ -285,10 +285,10 @@   -- | 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, Constructor c, Projection p (PhantomDb m) (RestrictionHolder v c) a, HasSelectOptions opts (PhantomDb m) (RestrictionHolder v c))                 => p                 -> opts-                -> m [a']+                -> m [a]   -- | Check database schema and create migrations for the entity and the entities it contains   migrate       :: PersistEntity v => v -> Migration m   -- | Execute raw query@@ -483,8 +483,8 @@   toPurePersistValues :: DbDescriptor db => Proxy db -> a -> ([PersistValue] -> [PersistValue])   fromPurePersistValues :: DbDescriptor db => Proxy db -> [PersistValue] -> (a, [PersistValue]) --- | Datatypes which can be converted directly to 'PersistValue'. The no-value parameter @DbDescriptor db => Proxy db@ allows conversion depend the database details while keeping it pure.-class (SinglePersistField a, PurePersistField a) => PrimitivePersistField a where+-- | Datatypes which can be converted directly to 'PersistValue'. The no-value parameter @DbDescriptor db => Proxy db@ allows conversion depend the database details while keeping it pure. A type which has an instance of 'PrimitivePersistField' should be an instance of superclasses 'SinglePersistField' and 'PurePersistField' as well.+class PersistField a => PrimitivePersistField a where   toPrimitivePersistValue :: DbDescriptor db => Proxy db -> a -> PersistValue   fromPrimitivePersistValue :: DbDescriptor db => Proxy db -> PersistValue -> a 

@@ -42,10 +42,11 @@ instance (PersistEntity v, Constructor c, PersistField a, RestrictionHolder v c ~ r') => Expression db r' (SubField v c a) where
   toExpr = ExprField . fieldChain
 
-instance (PersistEntity v, Constructor c, PersistField (Key v BackendSpecific), FieldLike (AutoKeyField v c) db r' a') => Expression db r' (AutoKeyField v c) where
+instance (PersistEntity v, Constructor c, RestrictionHolder v c ~ r') => Expression db r' (AutoKeyField v c) where
   toExpr = ExprField . fieldChain
 
-instance (PersistEntity v, FieldLike (u (UniqueMarker v)) db r' a', r' ~ RestrictionHolder v (UniqueConstr (Key v (Unique u))),  IsUniqueKey (Key v (Unique u))) => Expression db r' (u (UniqueMarker v)) where
+instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), RestrictionHolder v (UniqueConstr k) ~ r')
+      => Expression db r' (u (UniqueMarker v)) where
   toExpr = ExprField . fieldChain
 
 -- Let's call "plain type" the types that uniquely define type of a Field it is compared to.

@@ -21,6 +21,10 @@   -- * Helper functions for defining *PersistValue instances   , primToPersistValue   , primFromPersistValue+  , primToPurePersistValues+  , primFromPurePersistValues+  , primToSinglePersistValue+  , primFromSinglePersistValue   , pureToPersistValue   , pureFromPersistValue   , singleToPersistValue@@ -58,7 +62,6 @@ import Data.Either (partitionEithers) import Data.Function (on) import Data.List (partition, sortBy)-import Data.Maybe (fromMaybe) import qualified Data.Map as Map  getCorrectMigrations :: NamedMigrations -> [(Bool, Int, String)]@@ -164,20 +167,20 @@   DbEmbedded emb -> DbEmbedded $ applyToDef emb   DbEntity (Just (emb, uniq)) onDel onUpd e -> DbEntity (Just (applyToDef emb, uniq)) onDel onUpd e   t -> error $ "applyEmbeddedDbTypeSettings: expected DbEmbedded, got " ++ show t) where-  applyToDef (EmbeddedDef _ fields) = EmbeddedDef True $ go settings fields-  go [] fs = fs+  applyToDef (EmbeddedDef _ fields) = uncurry EmbeddedDef $ go settings fields+  go [] fs = (False, fs)   go st [] = error $ "applyEmbeddedDbTypeSettings: embedded datatype does not have following fields: " ++ show st-  go st (f@(fName, fType):fs) = case find fName st of-    Just (rest, PSEmbeddedFieldDef _ dbName dbTypeName subs) -> (fromMaybe fName dbName, typ'):go rest fs where+  go st (f@(fName, fType):fs) = case partition ((== fName) . psEmbeddedFieldName) st of+    ([PSEmbeddedFieldDef _ dbName dbTypeName subs], 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-    Nothing -> f:go st fs-  find :: String -> [PSEmbeddedFieldDef] -> Maybe ([PSEmbeddedFieldDef], PSEmbeddedFieldDef)-  find _ [] = Nothing-  find name (def:defs) | psEmbeddedFieldName def == name = Just (defs, def)-                       | otherwise = fmap (\(defs', result) -> (def:defs', result)) $ find name defs+    _ -> let (flag, fields') = go st fs in (flag, f:fields')  applyReferencesSettings :: Maybe ReferenceActionType -> Maybe ReferenceActionType -> DbType -> DbType applyReferencesSettings onDel onUpd typ = case typ of@@ -192,6 +195,19 @@ primFromPersistValue (x:xs) = phantomDb >>= \p -> return (fromPrimitivePersistValue p x, xs) primFromPersistValue xs = (\a -> fail (failMessage a xs) >> return (a, xs)) undefined +primToPurePersistValues :: (DbDescriptor db, PrimitivePersistField a) => Proxy db -> a -> ([PersistValue] -> [PersistValue])+primToPurePersistValues p a = (toPrimitivePersistValue p a:)++primFromPurePersistValues :: (DbDescriptor db, PrimitivePersistField a) => Proxy db -> [PersistValue] -> (a, [PersistValue])+primFromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)+primFromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined++primToSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => a -> m PersistValue+primToSinglePersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a)++primFromSinglePersistValue :: (PersistBackend m, PrimitivePersistField a) => PersistValue -> m a+primFromSinglePersistValue a = phantomDb >>= \p -> return (fromPrimitivePersistValue p a)+ pureToPersistValue :: (PersistBackend m, PurePersistField a) => a -> m ([PersistValue] -> [PersistValue]) pureToPersistValue a = phantomDb >>= \p -> return (toPurePersistValues p a) @@ -207,7 +223,7 @@  toSinglePersistValueUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u)))                            => u (UniqueMarker v) -> v -> m PersistValue-toSinglePersistValueUnique u v = insertBy u v >> toSinglePersistValue (extractUnique v :: Key v (Unique u))+toSinglePersistValueUnique u v = insertBy u v >> primToSinglePersistValue (extractUnique v :: Key v (Unique u))  fromSinglePersistValueUnique :: forall m v u . (PersistBackend m, PersistEntity v, IsUniqueKey (Key v (Unique u)), PrimitivePersistField (Key v (Unique u)))                              => u (UniqueMarker v) -> PersistValue -> m v@@ -223,7 +239,7 @@  toSinglePersistValueAutoKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (AutoKey v))                             => v -> m PersistValue-toSinglePersistValueAutoKey a = insertByAll a >>= toSinglePersistValue . either id id+toSinglePersistValueAutoKey a = insertByAll a >>= primToSinglePersistValue . either id id  fromSinglePersistValueAutoKey :: forall m v . (PersistBackend m, PersistEntity v, PrimitivePersistField (Key v BackendSpecific))                               => PersistValue -> m v

@@ -2,10 +2,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Groundhog.Instances (Selector(..)) where -import Control.Monad (liftM)- import Database.Groundhog.Core-import Database.Groundhog.Generic (failMessage, primToPersistValue, primFromPersistValue, pureFromPersistValue, phantomDb)+import Database.Groundhog.Generic (primToPersistValue, primFromPersistValue, primToPurePersistValues, primFromPurePersistValues, primToSinglePersistValue, primFromSinglePersistValue, pureFromPersistValue, phantomDb)  import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -56,28 +54,7 @@   selectorNum Tuple5_2Selector = 2   selectorNum Tuple5_3Selector = 3   selectorNum Tuple5_4Selector = 4-  -instance PrimitivePersistField a => SinglePersistField a where-  toSinglePersistValue a = phantomDb >>= \p -> return (toPrimitivePersistValue p a)-  fromSinglePersistValue a = phantomDb >>= \p -> return (fromPrimitivePersistValue p a) -instance (SinglePersistField a, NeverNull a) => SinglePersistField (Maybe a) where-  toSinglePersistValue Nothing = return PersistNull-  toSinglePersistValue (Just a) = toSinglePersistValue a-  fromSinglePersistValue PersistNull = return Nothing-  fromSinglePersistValue a = liftM Just $ fromSinglePersistValue a--instance PrimitivePersistField a => PurePersistField a where-  toPurePersistValues p a = (toPrimitivePersistValue p a:)-  fromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)-  fromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined--instance (PrimitivePersistField a, NeverNull a) => PurePersistField (Maybe a) where-  toPurePersistValues p a = (maybe PersistNull (toPrimitivePersistValue p) a:)-  fromPurePersistValues _ (PersistNull:xs) = (Nothing, xs)-  fromPurePersistValues p (x:xs) = (fromPrimitivePersistValue p x, xs)-  fromPurePersistValues _ xs = (\a -> error (failMessage a xs) `asTypeOf` (a, xs)) undefined- instance PurePersistField () where   toPurePersistValues _ _ = id   fromPurePersistValues _ xs = ((), xs)@@ -226,6 +203,166 @@   toPrimitivePersistValue p (KeyForBackend a) = toPrimitivePersistValue p a   fromPrimitivePersistValue p x = KeyForBackend (fromPrimitivePersistValue p x) +instance SinglePersistField String where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField T.Text where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField ByteString where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Int where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Int8 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Int16 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Int32 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Int64 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Word8 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Word16 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Word32 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Word64 where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Double where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Bool where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField Day where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField TimeOfDay where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField UTCTime where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance SinglePersistField ZonedTime where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance (PrimitivePersistField a, NeverNull a) => SinglePersistField (Maybe a) where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance (DbDescriptor db, PersistEntity v) => SinglePersistField (KeyForBackend db v) where+  toSinglePersistValue = primToSinglePersistValue+  fromSinglePersistValue = primFromSinglePersistValue++instance PurePersistField String where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField T.Text where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField ByteString where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Int where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Int8 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Int16 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Int32 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Int64 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Word8 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Word16 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Word32 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Word64 where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Double where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Bool where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField Day where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField TimeOfDay where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField UTCTime where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance PurePersistField ZonedTime where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance (PrimitivePersistField a, NeverNull a) => PurePersistField (Maybe a) where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues++instance (DbDescriptor db, PersistEntity v) => PurePersistField (KeyForBackend db v) where+  toPurePersistValues = primToPurePersistValues+  fromPurePersistValues = primFromPurePersistValues+ instance NeverNull String instance NeverNull T.Text instance NeverNull ByteString@@ -460,7 +597,7 @@   projectionExprs e = (ExprRaw e:)   projectionResult _ = fromPersistValues -instance (PersistEntity v, Constructor c, PersistField (Key v BackendSpecific)) => Projection (AutoKeyField v c) db (RestrictionHolder v c) (Key v BackendSpecific) where+instance (PersistEntity v, Constructor c, a ~ AutoKey v) => Projection (AutoKeyField v c) db (RestrictionHolder v c) a where   projectionExprs f = (ExprField (fieldChain f):)   projectionResult _ = fromPersistValues @@ -471,8 +608,8 @@     constr = constructors e !! phantomConstrNum c   projectionResult c xs = toSinglePersistValue (phantomConstrNum c) >>= \cNum -> fromEntityPersistValues (cNum:xs) -instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), r ~ RestrictionHolder v (UniqueConstr (Key v (Unique u))))-      => Projection (u (UniqueMarker v)) db r (Key v (Unique u)) where+instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), r ~ RestrictionHolder v (UniqueConstr k))+      => 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)     chains = map (\f -> (f, [])) uFields@@ -514,27 +651,27 @@     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 (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) db r a') => Assignable (u (UniqueMarker v)) db r a' -instance (PersistEntity v, Constructor c, Projection (AutoKeyField v c) db r a') => FieldLike (AutoKeyField v c) db r a' where+instance (PersistEntity v, Constructor c, a ~ AutoKey v) => FieldLike (AutoKeyField v c) db (RestrictionHolder v c) a where   fieldChain a = chain where-    chain = maybe (error "fieldChain AutoKeyField: constructor constrAutoKeyName == Nothing") (\idName -> ((idName, DbEntity Nothing Nothing Nothing e), [])) $ constrAutoKeyName constr+    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)-    constr = constructors e !! cNum -instance (PersistEntity v, Constructor c, Projection (SubField v c a) db r a') => FieldLike (SubField v c a) db r a' where+instance (PersistEntity v, Constructor c, PersistField a) => FieldLike (SubField v c a) db (RestrictionHolder v c) a where   fieldChain (SubField a) = a -instance (PersistEntity v, Constructor c, Projection (Field v c a) db r a') => FieldLike (Field v c a) db r a' where+instance (PersistEntity v, Constructor c, PersistField a) => FieldLike (Field v c a) db (RestrictionHolder v c) a where   fieldChain = entityFieldChain -instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) db r a') => FieldLike (u (UniqueMarker v)) db r a' where+instance (PersistEntity v, IsUniqueKey k, k ~ Key v (Unique u), r ~ RestrictionHolder v (UniqueConstr k))+      => 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), [])

@@ -1,38 +1,36 @@-{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-}+{-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances, StandaloneDeriving #-} import Control.Monad.IO.Class (liftIO) import Database.Groundhog.TH import Database.Groundhog.Sqlite -data Customer a = Customer {customerName :: String, remark :: a} deriving Show-data Product = Product {productName :: String, quantity :: Int, customer :: Customer String} deriving Show+data Customer = Customer {customerName :: String, phone :: String} deriving Show+data Product = Product {productName :: String, quantity :: Int, customer :: DefaultKey Customer}+deriving instance Show Product --- Code generator will derive the necessary instances and generate other boilerplate code for the entities defined below.--- It will also create function migrateAll that migrates schema for all non-polymorphic entities -mkPersist (defaultCodegenConfig {migrationFunction = Just "migrateAll"}) [groundhog|-- entity: Customer+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]+          fields: [customerName] # Inline format of list - entity: Product |] -main = withSqliteConn ":memory:" $ runDbConn $ do-  -- Customer is also migrated because Product references it.-  -- It is possible to migrate schema for given type, e.g. migrate (undefined :: Customer String), or run migrateAll-  runMigration defaultMigrationLogger migrateAll-  let john = Customer "John Doe" "Phone: 01234567"-  johnKey <- insert john-  -- John is inserted only once because of the name constraint-  insert $ Product "Apples" 5 john-  insert $ Product "Melon" 2 john-  -- Groundhog prevents SQL injections. Quotes and other special symbols are safe.-  insert $ Product "Melon" 6 (Customer "Jack Smith" "Don't let him pay by check")+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+  productsForJohn <- select $ (CustomerField ==. johnKey) `orderBy` [Asc ProductNameField]   liftIO $ putStrLn $ "Products for John: " ++ show productsForJohn-  -- check bonus-  melon <- select $ (ProductNameField ==. "Melon") `orderBy` [Desc QuantityField]-  liftIO $ putStrLn $ "Melon orders: " ++ show melon

@@ -20,6 +20,15 @@   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|

@@ -4,15 +4,19 @@ import Database.Groundhog.TH
 import Database.Groundhog.Sqlite
 
--- artistName is a unique key
 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 SomeEntity
+      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
@@ -23,20 +27,6 @@             # Optional parameter type can be constraint (by default), index, or primary
             type: constraint
             fields: [artistName]
-|]
-
-data Album  = Album  { albumName :: String} deriving (Eq, Show)
--- many-to-many relation
-data ArtistAlbum = ArtistAlbum {artist :: Key Artist (Unique ArtistName), album :: Key Album BackendSpecific }
-deriving instance Eq ArtistAlbum
-deriving instance Show ArtistAlbum
--- 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: Album
   - entity: Track
     constructors:
@@ -46,9 +36,17 @@   # Configure actions on parent table changes
             onDelete: cascade
             onUpdate: restrict
-  # Keys of many-to-many relation form a unique key
+|]
+
+-- 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
+    autoKey: null # Disable creation of the autoincrement integer key
     keys:
       - name: ArtistAlbumKey
         default: true
@@ -76,5 +74,4 @@   [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'
-
+  liftIO $ print tracks'

@@ -1,7 +1,7 @@ {-# LANGUAGE GADTs, TypeFamilies, TemplateHaskell, QuasiQuotes, FlexibleInstances #-} import Control.Monad (liftM, (>=>)) import Control.Monad.IO.Class (liftIO)-import Database.Groundhog.Core (PersistValue, PersistField(..), PrimitivePersistField(..), RowPopper)+import Database.Groundhog.Core (PersistValue, PersistField(..), PrimitivePersistField(..), RowPopper, PersistEntity(..)) import Database.Groundhog.Generic (mapAllRows, phantomDb) import Database.Groundhog.TH import Database.Groundhog.Sqlite

@@ -9,8 +9,8 @@ mkPersist defaultCodegenConfig $ PersistDefinitions [   Left $ PSEntityDef "Table" Nothing Nothing Nothing Nothing $ Just [     PSConstructorDef "Create" Nothing Nothing Nothing (Just [-        PSFieldDef "select" (Just "SELECT") Nothing Nothing Nothing-      , PSFieldDef "fubar" (Just "BEGIN COMMIT") Nothing Nothing Nothing+        PSFieldDef "select" (Just "SELECT") Nothing Nothing Nothing Nothing Nothing+      , PSFieldDef "fubar" (Just "BEGIN COMMIT") Nothing Nothing Nothing Nothing Nothing       ])       Nothing     ]

@@ -1,5 +1,5 @@ name:            groundhog-version:         0.3.0.1+version:         0.3.1 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>