groundhog 0.1.0.2 → 0.2.0

raw patch · 9 files changed

+140/−155 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Database/Groundhog/Core.hs +13/−8
• Database/Groundhog/Expression.hs +14/−14
• Database/Groundhog/Generic.hs +6/−1
• Database/Groundhog/Generic/Migration.hs +54/−52
• Database/Groundhog/Generic/PersistBackendHelpers.hs +2/−3
• Database/Groundhog/Instances.hs +3/−2
• examples/compositeKeys.hs +0/−74
• examples/dbSpecificTypes.hs +47/−0
• groundhog.cabal +1/−1

@@ -51,6 +51,7 @@   , Constructor(..)   , IsUniqueKey(..)   , UniqueDef(..)+  , UniqueType(..)   -- * Migration   , SingleMigration   , NamedMigrations@@ -96,7 +97,7 @@   -- | Constructs the value from the list of 'PersistValue'   fromEntityPersistValues :: PersistBackend m => [PersistValue] -> m (v, [PersistValue])   -- | Returns constructor number and a list of uniques names and corresponding field values-  getUniques :: DbDescriptor db => Proxy db -> v -> (Int, [(String, [PersistValue])])+  getUniques :: DbDescriptor db => Proxy db -> v -> (Int, [(String, [PersistValue] -> [PersistValue])])   -- | Is internally used by FieldLike Field instance   -- We could avoid this function if class FieldLike allowed FieldLike Fields Data or FieldLike (Fields Data). However that would require additional extensions in user-space code   entityFieldChain :: Field v c a -> FieldChain@@ -332,13 +333,16 @@   extractUnique :: uKey ~ Key v u => v -> uKey   uniqueNum :: uKey -> Int --- | Unique name and list of the field names that form a unique combination.--- Only fields of 'PrimitivePersistField' types can be used in a unique definition+-- | Unique name and list of the field names that form a unique combination data UniqueDef = UniqueDef {     uniqueName :: String+  , uniqueType :: UniqueType   , uniqueFields :: [(String, DbType)]-}  deriving (Show, Eq)+} deriving (Show, Eq) +-- | Defines how to treat the unique set of fields for a datatype+data UniqueType = UniqueConstraint | UniqueIndex deriving (Show, Eq)+ -- | 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.@@ -351,12 +355,13 @@             | DbTime             | DbDayTime             | DbDayTimeZoned-            | DbBlob    -- ByteString--- More complex types+            | DbBlob         -- ^ ByteString+            | DbOther String -- ^ Name for a database type+            -- More complex types             | DbMaybe DbType-            | DbList String DbType -- list name and type of its argument+            | 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.+            -- | Nothing means autokey, Just contains a unique key definition and a name of unique constraint.             | DbEntity (Maybe (EmbeddedDef, String)) EntityDef   deriving (Eq, Show) 

@@ -22,25 +22,25 @@ 
 -- | Instances of this type can be converted to 'Expr'. It is useful for uniform manipulation over fields and plain values
 class Expression a v c where
-  wrap :: a -> Expr v c a
+  toExpression :: a -> Expr v c a
 
 instance PurePersistField a => Expression a v c where
-  wrap = ExprPure
+  toExpression = ExprPure
 
 instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Arith v c a) v' c' where
-  wrap = ExprArith
+  toExpression = ExprArith
 
 instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (Field v c a) v' c' where
-  wrap = ExprField
+  toExpression = ExprField
 
 instance (PersistEntity v, Constructor c, PersistField a, v ~ v', c ~ c') => Expression (SubField v c a) v' c' where
-  wrap = ExprField
+  toExpression = ExprField
 
 instance (PersistEntity v, Constructor c, PersistField (Key v' BackendSpecific), FieldLike (AutoKeyField v c) (RestrictionHolder v c) a', v ~ v', c ~ c') => Expression (AutoKeyField v c) v' c' where
-  wrap = ExprField
+  toExpression = ExprField
 
 instance (PersistEntity v, Constructor c, FieldLike (u (UniqueMarker v)) (RestrictionHolder v c) a', c' ~ UniqueConstr (Key v' (Unique u)), v ~ v', IsUniqueKey (Key v' (Unique u)), c ~ c') => Expression (u (UniqueMarker v)) v' c' where
-  wrap = ExprField
+  toExpression = ExprField
 
 -- Let's call "plain type" the types that uniquely define type of a Field it is compared to.
 -- Example: Int -> Field v c Int, but Entity -> Field v c (Entity / Key Entity)
@@ -94,7 +94,7 @@   , FieldLike f (RestrictionHolder v c) a'
   , Unifiable f b)
   => f -> b -> Update v c
-f =. b = Update f (wrap b)
+f =. b = Update f (toExpression b)
 
 -- | Boolean \"and\" operator.
 (&&.) :: Cond v c -> Cond v c -> Cond v c
@@ -121,9 +121,9 @@   => a -> b -> Cond v c
 
 infix 4 ==., <., <=., >., >=.
-a ==. b = Compare Eq (wrap a) (wrap b)
-a /=. b = Compare Ne (wrap a) (wrap b)
-a <.  b = Compare Lt (wrap a) (wrap b)
-a <=. b = Compare Le (wrap a) (wrap b)
-a >.  b = Compare Gt (wrap a) (wrap b)
-a >=. b = Compare Ge (wrap a) (wrap b)
+a ==. b = Compare Eq (toExpression a) (toExpression b)
+a /=. b = Compare Ne (toExpression a) (toExpression b)
+a <.  b = Compare Lt (toExpression a) (toExpression b)
+a <=. b = Compare Le (toExpression a) (toExpression b)
+a >.  b = Compare Gt (toExpression a) (toExpression b)
+a >=. b = Compare Ge (toExpression a) (toExpression b)

@@ -149,6 +149,7 @@ data PSEmbeddedFieldDef = PSEmbeddedFieldDef {     psEmbeddedFieldName :: String -- bar   , psDbEmbeddedFieldName :: Maybe String -- SQLbar+  , psDbEmbeddedTypeName :: Maybe String -- inet, NUMERIC(5, 2), VARCHAR(50)   , psSubEmbedded :: Maybe [PSEmbeddedFieldDef] } deriving Show @@ -161,7 +162,11 @@   go [] fs = 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 subs) -> (fromMaybe fName dbName, maybe id applyEmbeddedDbTypeSettings subs fType):go rest fs+    Just (rest, PSEmbeddedFieldDef _ dbName dbTypeName subs) -> (fromMaybe fName dbName, typ'):go rest fs where+      typ' = case (subs, dbTypeName) of+        (Just e, _) -> applyEmbeddedDbTypeSettings e fType+        (_, Just typeName) -> DbOther typeName+        _ -> fType     Nothing -> f:go st fs   find :: String -> [PSEmbeddedFieldDef] -> Maybe ([PSEmbeddedFieldDef], PSEmbeddedFieldDef)   find _ [] = Nothing

@@ -25,76 +25,77 @@ import Control.Monad (liftM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT (..), gets, modify)+import Data.Function (on) import qualified Data.Map as Map import Data.List (group, intercalate) import Data.Maybe (fromJust, fromMaybe, mapMaybe, maybeToList)  -- Describes a database column. Field cType always contains DbType that maps to one column (no DbEmbedded)-data Column typ = Column+data Column = Column     { colName :: String     , colNull :: Bool-    , colType :: typ+    , colType :: DbType     , colDefault :: Maybe String     } deriving (Eq, Show)  -- | Foreign table name and names of the corresponding columns type Reference = (String, [(String, String)]) -data TableInfo typ = TableInfo {+data TableInfo = TableInfo {     tablePrimaryKeyName :: Maybe String-  , tableColumns :: [Column typ]+  , tableColumns :: [Column]   , tableUniques :: [UniqueDef']     -- | constraint name and reference   , tableReferences :: [(Maybe String, Reference)] } deriving Show -data AlterColumn = Type DbType | IsNull | NotNull | Add (Column DbType) | Drop | AddPrimaryKey+data AlterColumn = Type DbType | IsNull | NotNull | Add Column | Drop | AddPrimaryKey                  | Default String | NoDefault | UpdateValue String deriving Show  type AlterColumn' = (String, AlterColumn) -data AlterTable = AddUniqueConstraint String [String]+data AlterTable = AddUnique UniqueDef'                 | DropConstraint String+                | DropIndex String                 | AddReference Reference                 | DropReference String                 | AlterColumn AlterColumn' deriving Show -data AlterDB typ = AddTable String-                 -- | Table name, create statement, structure of table from DB, structure of table from datatype, alters-                 | AlterTable String String (TableInfo typ) (TableInfo DbType) [AlterTable]-                 -- | Trigger name, table name-                 | DropTrigger String String-                 -- | Trigger name, table name, body-                 | AddTriggerOnDelete String String String-                 -- | Trigger name, table name, field name, body-                 | AddTriggerOnUpdate String String String String-                 | CreateOrReplaceFunction String-                 | DropFunction String+data AlterDB = AddTable String+             -- | Table name, create statement, structure of table from DB, structure of table from datatype, alters+             | AlterTable String String TableInfo TableInfo [AlterTable]+             -- | Trigger name, table name+             | DropTrigger String String+             -- | Trigger name, table name, body+             | AddTriggerOnDelete String String String+             -- | Trigger name, table name, field name, body+             | AddTriggerOnUpdate String String String String+             | CreateOrReplaceFunction String+             | DropFunction String   deriving Show -data UniqueDef' = UniqueDef' String [String] deriving Show+data UniqueDef' = UniqueDef' String UniqueType [String] deriving Show -data MigrationPack m typ = MigrationPack {-    compareColumns :: Column typ -> Column DbType -> Bool+data MigrationPack m = MigrationPack {+    compareTypes :: DbType -> DbType -> Bool   , compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool   , compareUniqs :: UniqueDef' -> UniqueDef' -> Bool-  , checkTable :: String -> m (Maybe (Either [String] (TableInfo typ)))-  , migTriggerOnDelete :: String -> [(String, String)] -> m (Bool, [AlterDB typ])-  , migTriggerOnUpdate :: String -> String -> String -> m (Bool, [AlterDB typ])-  , migConstr :: MigrationPack m typ -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)+  , checkTable :: String -> m (Maybe (Either [String] TableInfo))+  , migTriggerOnDelete :: String -> [(String, String)] -> m (Bool, [AlterDB])+  , migTriggerOnUpdate :: String -> String -> String -> m (Bool, [AlterDB])+  , migConstr :: MigrationPack m -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)   , escape :: String -> String   , primaryKeyType :: String   , foreignKeyType :: String   , mainTableId :: String   , defaultPriority :: Int-  , convertType :: DbType -> typ   -- | 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 DbType -> String-  , showAlterDb :: AlterDB typ -> SingleMigration+  , showColumn :: Column -> String+  , showAlterDb :: AlterDB -> SingleMigration } -mkColumns :: (DbType -> typ) -> String -> DbType -> ([Column typ], [Reference])+mkColumns :: (DbType -> DbType) -> String -> DbType -> ([Column], [Reference]) mkColumns mkType columnName dbtype = go "" (columnName, dbtype) where   go prefix (fname, typ) = (case typ of     DbEmbedded (EmbeddedDef False ts) -> concatMap' (go $ prefix ++ fname ++ [delim]) ts@@ -108,7 +109,7 @@       cDef = case constructors e of         [cDef'] -> cDef'         _       -> error "mkColumns: datatype with unique key cannot have more than one constructor"-      UniqueDef _ uFields = findOne "unique" id uniqueName uName $ constrUniques cDef+      UniqueDef _ _ uFields = findOne "unique" id uniqueName uName $ constrUniques cDef       fields = map (\(fName, _) -> findOne "field" id fst fName $ constrParams cDef) uFields       (foreignColumns, _) = concatMap' (go "") fields     t@(DbEntity Nothing e) -> ([Column name False (mkType t) Nothing], refs) where@@ -146,7 +147,7 @@       _ -> return ()   allSubtypes = map snd . concatMap constrParams . constructors -migrateEntity :: (Monad m, Show typ) => MigrationPack m typ -> EntityDef -> m SingleMigration+migrateEntity :: Monad m => MigrationPack m -> EntityDef -> m SingleMigration migrateEntity m@MigrationPack{..} e = do   let name = entityName e   let constrs = constructors e@@ -158,7 +159,7 @@       x <- checkTable name       -- check whether the table was created for multiple constructors before       case x of-        Just (Right old) | haveSameElems compareColumns (tableColumns old) mainTableColumns -> do+        Just (Right old) | haveSameElems (compareColumns m) (tableColumns old) mainTableColumns -> do           return $ Left ["Datatype with multiple constructors was truncated to one constructor. Manual migration required. Datatype: " ++ name]         Just (Left errs) -> return (Left errs)         _ -> liftM snd $ migConstr m True name $ head constrs@@ -174,7 +175,7 @@             then mergeMigrations $ Right [(False, defaultPriority, mainTableQuery)]:map snd res             else Left $ map (\(_, c) -> "Orphan constructor table found: " ++ constrTable c) orphans         Just (Right (TableInfo (Just _) columns [] [])) -> do-          if haveSameElems compareColumns columns mainTableColumns+          if haveSameElems (compareColumns m) columns mainTableColumns             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@@ -189,7 +190,7 @@           return $ Left ["Unexpected structure of main table for Datatype: " ++ name ++ ". Table info: " ++ show structure]         Just (Left errs) -> return (Left errs) -migrateList :: (Monad m, Show typ) => MigrationPack m typ -> DbType -> m SingleMigration+migrateList :: Monad m => MigrationPack m -> DbType -> m SingleMigration migrateList m@MigrationPack{..} (DbList mainName t) = do   let valuesName = mainName ++ delim : "values"   let (valueCols, valueRefs) = mkColumns id "value" t@@ -206,11 +207,10 @@   (_, triggerValues) <- migTriggerOnDelete valuesName $ mkDeletes m valueCols   return $ case (mainStructure, valuesStructure) of     (Nothing, Nothing) -> let-      oldValuesStructure = expectedValuesStructure {tableColumns = map (\c -> c {colType = convertType (colType c)}) valueColumns}-      rest = [AlterTable valuesName valuesQuery oldValuesStructure expectedValuesStructure addInAlters]+      rest = [AlterTable valuesName valuesQuery expectedValuesStructure expectedValuesStructure addInAlters]       in mergeMigrations $ map showAlterDb $ [AddTable mainQuery, AddTable valuesQuery] ++ rest ++ triggerMain ++ triggerValues     (Just (Right mainStructure'), Just (Right valuesStructure')) -> let-      f name a@(TableInfo id1 cols1 uniqs1 refs1) b@(TableInfo id2 cols2 uniqs2 refs2) = if id1 == id2 && haveSameElems compareColumns cols1 cols2 && haveSameElems compareUniqs uniqs1 uniqs2 && haveSameElems compareRefs refs1 refs2+      f name a@(TableInfo id1 cols1 uniqs1 refs1) b@(TableInfo id2 cols2 uniqs2 refs2) = if id1 == id2 && haveSameElems (compareColumns m) cols1 cols2 && haveSameElems compareUniqs uniqs1 uniqs2 && haveSameElems compareRefs refs1 refs2         then []         else ["List table " ++ name ++ " error. Expected: " ++ show b ++ ". Found: " ++ show a]       errors = f mainName mainStructure' expectedMainStructure ++ f valuesName valuesStructure' expectedValuesStructure@@ -223,14 +223,13 @@ migrateList _ t = fail $ "migrateList: expected DbList, got " ++ show t  -- from database, from datatype-getAlters :: (Eq typ, Show typ) =>-             MigrationPack m typ-          -> TableInfo typ-          -> TableInfo DbType+getAlters :: MigrationPack m+          -> TableInfo+          -> TableInfo           -> [AlterTable] getAlters m@MigrationPack{..} (TableInfo oldId oldColumns oldUniques oldRefs) (TableInfo newId newColumns newUniques newRefs) = map AlterColumn colAlters ++ tableAlters   where-    (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements compareColumns oldColumns newColumns+    (oldOnlyColumns, newOnlyColumns, commonColumns) = matchElements ((==) `on` colName) oldColumns newColumns     (oldOnlyUniques, newOnlyUniques, commonUniques) = matchElements compareUniqs oldUniques newUniques     primaryKeyAlters = case (oldId, newId) of       (Nothing, Just newName) -> [(newName, AddPrimaryKey)]@@ -241,14 +240,14 @@      colAlters = map (\x -> (colName x, Drop)) oldOnlyColumns ++ map (\x -> (colName x, Add x)) newOnlyColumns ++ concatMap (migrateColumn m) commonColumns ++ primaryKeyAlters     tableAlters = -         map (\(UniqueDef' name _) -> DropConstraint name) oldOnlyUniques-      ++ map (\(UniqueDef' name cols) -> AddUniqueConstraint name cols) newOnlyUniques+         map (\(UniqueDef' name typ _) -> case typ of UniqueConstraint -> DropConstraint name; UniqueIndex -> DropIndex name) oldOnlyUniques+      ++ map AddUnique newOnlyUniques       ++ concatMap migrateUniq commonUniques       ++ map (DropReference . fromMaybe (error "getAlters: old reference does not have name") . fst) oldOnlyRefs       ++ map (AddReference . snd) newOnlyRefs  -- from database, from datatype-migrateColumn :: Eq typ => MigrationPack m typ -> (Column typ, Column DbType) -> [AlterColumn']+migrateColumn :: MigrationPack m -> (Column, Column) -> [AlterColumn'] migrateColumn MigrationPack{..} (Column name1 isNull1 type1 def1, Column _ isNull2 type2 def2) = modDef ++ modNull ++ modType where   modNull = case (isNull1, isNull2) of     (False, True) -> [(name1, IsNull)]@@ -256,18 +255,18 @@       Nothing -> [(name1, NotNull)]       Just s -> [(name1, UpdateValue s), (name1, NotNull)]     _ -> []-  modType = if type1 == convertType type2 then [] else [(name1, Type type2)]+  modType = if compareTypes type1 type2 then [] else [(name1, Type type2)]   modDef = if def1 == def2     then []     else [(name1, maybe NoDefault Default def2)]  -- from database, from datatype migrateUniq :: (UniqueDef', UniqueDef') -> [AlterTable]-migrateUniq (UniqueDef' name1 cols1, UniqueDef' name2 cols2) = if haveSameElems (==) cols1 cols2+migrateUniq (UniqueDef' name1 _ cols1, u2@(UniqueDef' _ typ2 cols2)) = if haveSameElems (==) cols1 cols2   then []-  else [DropConstraint name1, AddUniqueConstraint name2 cols2]+  else [if typ2 == UniqueConstraint then DropConstraint name1 else DropIndex name1, AddUnique u2]   -defaultMigConstr :: (Monad m, Eq typ, Show typ) => MigrationPack m typ -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration)+defaultMigConstr :: Monad m => MigrationPack m -> Bool -> String -> ConstructorDef -> m (Bool, SingleMigration) defaultMigConstr migPack@MigrationPack{..} simple name constr = do   let cName = if simple then name else name ++ [delim] ++ constrName constr   let mkColumns' xs = concat *** concat $ unzip $ map (uncurry $ mkColumns id) xs@@ -283,7 +282,7 @@       mainRef = maybe "" (\x -> " REFERENCES " ++ escape x ++ " ON DELETE CASCADE ") mainTableName       autoKey = fmap (\x -> escape x ++ " " ++ primaryKeyType ++ mainRef) $ constrAutoKeyName constr -      uniques = map (\(UniqueDef uName cols) -> UniqueDef' uName (map colName $ fst $ mkColumns' cols)) $ constrUniques constr+      uniques = map (\(UniqueDef uName uType cols) -> UniqueDef' uName uType (map colName $ fst $ mkColumns' cols)) $ constrUniques constr       (addInCreate, addInAlters) = addUniquesReferences uniques refs       -- refs instead of refs' because the reference to the main table id is hardcoded in mainRef       items = maybeToList autoKey ++ map showColumn columns ++ addInCreate@@ -292,8 +291,7 @@       expectedTableStructure = TableInfo (constrAutoKeyName constr) columns uniques (map (\r -> (Nothing, r)) refs')       (migErrs, constrExisted, mig) = case tableStructure of         Nothing  -> let-          oldTableStructure = expectedTableStructure {tableColumns = map (\c -> c {colType = convertType (colType c)}) columns}-          rest = AlterTable cName addTable oldTableStructure expectedTableStructure addInAlters+          rest = AlterTable cName addTable expectedTableStructure expectedTableStructure addInAlters           in ([], False, [AddTable addTable, rest])         Just (Right oldTableStructure) -> let           alters = getAlters migPack oldTableStructure expectedTableStructure@@ -309,10 +307,14 @@  -- on delete removes all ephemeral data -- returns column name and delete statement for the referenced table-mkDeletes :: MigrationPack m typ -> [Column DbType] -> [(String, String)]+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++compareColumns :: MigrationPack m -> Column -> Column -> Bool+compareColumns MigrationPack{..} (Column name1 isNull1 type1 def1) (Column name2 isNull2 type2 def2) =+  name1 == name2 && isNull1 == isNull2 && compareTypes type1 type2 && def1 == def2

@@ -250,12 +250,11 @@    let (constructorNum, uniques) = getUniques proxy v   let uniqueDefs = constrUniques $ constructors e !! constructorNum-  let cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ fields) -> fields) uniqueDefs+  let cond = intercalateS " OR " $ map (intercalateS " AND " . map (\(fname, _) -> escape (fromString fname) <> "=?")) $ map (\(UniqueDef _ _ fields) -> fields) uniqueDefs    let ifAbsent tname constr = do       let query = "SELECT " <> maybe "1" id (constrId escape constr) <> " FROM " <> escape (fromString tname) <> " WHERE " <> cond---      x <- queryFunc query [DbInt64] (foldr ((.) . snd) id uniques []) id-      x <- queryFunc query [DbInt64] (concatMap snd 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]

@@ -198,6 +198,7 @@ instance PrimitivePersistField Double where   toPrimitivePersistValue _ a = PersistDouble a   fromPrimitivePersistValue _ (PersistDouble a) = a+  fromPrimitivePersistValue _ (PersistInt64 a) = fromIntegral a   fromPrimitivePersistValue _ x = readHelper x ("Expected Double, received: " ++ show x)  instance PrimitivePersistField Bool where@@ -479,7 +480,7 @@ instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), r ~ RestrictionHolder v (UniqueConstr (Key v (Unique u))))       => Projection (u (UniqueMarker v)) r (Key v (Unique u)) where   projectionFieldChains u = (chains++) where-    UniqueDef _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)+    UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)     chains = map (\f -> (f, [])) uFields     constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u))   projectionResult _ = pureFromPersistValue@@ -533,6 +534,6 @@  instance (PersistEntity v, IsUniqueKey (Key v (Unique u)), Projection (u (UniqueMarker v)) r a') => FieldLike (u (UniqueMarker v)) r a' where   fieldChain u = chain where-    UniqueDef _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)+    UniqueDef _ _ uFields = constrUniques constr !! uniqueNum ((undefined :: u (UniqueMarker v) -> Key v (Unique u)) u)     chain = (("will_be_ignored", DbEmbedded $ EmbeddedDef True $ uFields), [])     constr = head $ constructors (entityDef ((undefined :: u (UniqueMarker v) -> v) u))

@@ -1,74 +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
-
--- artistName is a unique key
-data Artist = Artist { artistName :: String, artistSurname :: String } deriving (Eq, Show)
-
-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
-    keys:
-      - name: ArtistFullName
-        default: true
-    constructors:
-      - name: Artist
-        uniques:
-          - name: ArtistFullName
-            fields: [artistName, artistSurname]
-|]
-
-data Album  = Album  { albumName :: String} deriving (Eq, Show)
--- many-to-many relation
-data ArtistAlbum = ArtistAlbum {artist :: Key Artist (Unique ArtistFullName), 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
-# keys of many-to-many relation form a unique key
-- entity: ArtistAlbum
-  autoKey: null
-  keys:
-  - name: ArtistAlbumKey
-    default: true
-  constructors:
-  - name: ArtistAlbum
-    fields:
-    - name: artist
-      embeddedType: []
-    uniques:
-    - name: ArtistAlbumKey
-      fields: [artist, album]
-|]
-
-main :: IO ()
-main = withSqliteConn ":memory:" $ runSqliteConn $ 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 ==. ArtistFullNameKey "John" "Lennon") `limitTo` 1
-  -- order by primary key
-  tracks' <- select $ (AlbumTrackField ==. albumKey') `orderBy` [Asc AutoKeyField] `limitTo` 3
-  liftIO $ print tracks'
-

@@ -0,0 +1,47 @@+{-# 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 "point"++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" . runPostgresqlConn $ 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,5 +1,5 @@ name:            groundhog-version:         0.1.0.2+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>