groundhog-th 0.1.0.3 → 0.2.0

raw patch · 4 files changed

+235/−182 lines, 4 filesdep ~groundhogdep ~yamlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: groundhog, yaml

API changes (from Hackage documentation)

Files

• Database/Groundhog/TH.hs +98/−73
• Database/Groundhog/TH/CodeGen.hs +92/−87
• Database/Groundhog/TH/Settings.hs +42/−19
• groundhog-th.cabal +3/−3

@@ -18,7 +18,7 @@   , conciseNamingStyle   ) where -import Database.Groundhog.Core (delim)+import Database.Groundhog.Core (delim, UniqueType(..)) import Database.Groundhog.Generic import Database.Groundhog.TH.CodeGen import Database.Groundhog.TH.Settings@@ -30,8 +30,9 @@ import Data.Char (toUpper, toLower, isSpace) import Data.Either (lefts) import Data.List (nub, (\\))-import Data.Maybe (fromMaybe, isNothing)-import Data.Yaml (decodeEither)+import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Yaml as Y(decodeHelper, ParseException(..))+import qualified Text.Libyaml as Y  data CodegenConfig = CodegenConfig {     -- | Naming style that is applied for all definitions@@ -184,19 +185,19 @@   return $ migrateFunc ++ concat decs  applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef-applyEntitySettings style settings def@(THEntityDef{..}) =-  def { dbEntityName = fromMaybe dbEntityName $ psDbEntityName settings+applyEntitySettings style PSEntityDef{..} def@(THEntityDef{..}) =+  def { thDbEntityName = fromMaybe thDbEntityName psDbEntityName       , thAutoKey = thAutoKey'-      , thUniqueKeys = maybe thUniqueKeys (map mkUniqueKey') $ psUniqueKeys settings+      , thUniqueKeys = maybe thUniqueKeys (map mkUniqueKey') psUniqueKeys       , thConstructors = thConstructors'       } where-  thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) $ psAutoKey settings+  thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) psAutoKey -  thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors settings where+  thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors where     thConstructors'' = maybe id (\_ -> zipWith putAutoKey [0..]) thAutoKey' thConstructors-    putAutoKey cNum cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = Just $ mkDbConstrAutoKeyName style (nameBase dataName) (nameBase thConstrName) cNum}+    putAutoKey cNum cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = Just $ mkDbConstrAutoKeyName style (nameBase thDataName) (nameBase thConstrName) cNum} -  mkUniqueKey' = mkUniqueKey style (nameBase dataName) (head thConstructors')+  mkUniqueKey' = mkUniqueKey style (nameBase thDataName) (head thConstructors')   f = foldr $ replaceOne "constructor" psConstrName (nameBase . thConstrName) applyConstructorSettings  mkUniqueKey :: NamingStyle -> String -> THConstructorDef -> PSUniqueKeyDef -> THUniqueKeyDef@@ -210,44 +211,46 @@   , thUniqueKeyMakeEmbedded = fromMaybe False psUniqueKeyMakeEmbedded   , thUniqueKeyIsDef = fromMaybe False psUniqueKeyIsDef   }-  f = foldr $ replaceOne "unique field" psFieldName fieldName applyFieldSettings+  f = foldr $ replaceOne "unique field" psFieldName thFieldName applyFieldSettings   uniqueFields = mkFieldsForUniqueKey style dName key cDef  applyAutoKeySettings :: THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef-applyAutoKeySettings def@(THAutoKeyDef{..}) settings = -  def { thAutoKeyConstrName = fromMaybe thAutoKeyConstrName $ psAutoKeyConstrName settings-      , thAutoKeyIsDef = fromMaybe thAutoKeyIsDef $ psAutoKeyIsDef settings+applyAutoKeySettings def@(THAutoKeyDef{..}) PSAutoKeyDef{..} = +  def { thAutoKeyConstrName = fromMaybe thAutoKeyConstrName psAutoKeyConstrName+      , thAutoKeyIsDef = fromMaybe thAutoKeyIsDef psAutoKeyIsDef       }  applyConstructorSettings :: PSConstructorDef -> THConstructorDef -> THConstructorDef-applyConstructorSettings settings def@(THConstructorDef{..}) =-  def { thPhantomConstrName = fromMaybe thPhantomConstrName $ psPhantomConstrName settings-      , dbConstrName = fromMaybe dbConstrName $ psDbConstrName settings-      , thDbAutoKeyName = fromMaybe thDbAutoKeyName $ psDbAutoKeyName settings-      , thConstrFields = maybe thConstrFields (f thConstrFields) $ psConstrFields settings-      , thConstrUniques = fromMaybe thConstrUniques $ psConstrUniques settings+applyConstructorSettings PSConstructorDef{..} def@(THConstructorDef{..}) =+  def { thPhantomConstrName = fromMaybe thPhantomConstrName psPhantomConstrName+      , thDbConstrName = fromMaybe thDbConstrName psDbConstrName+      , thDbAutoKeyName = fromMaybe thDbAutoKeyName psDbAutoKeyName+      , thConstrFields = maybe thConstrFields (f thConstrFields) psConstrFields+      , thConstrUniques = maybe thConstrUniques (map convertUnique) psConstrUniques       } where-  f = foldr $ replaceOne "field" psFieldName fieldName applyFieldSettings+  f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings+  convertUnique (PSUniqueDef uName uType uFields) = THUniqueDef uName (fromMaybe UniqueConstraint uType) uFields    applyFieldSettings :: PSFieldDef -> THFieldDef -> THFieldDef-applyFieldSettings settings def@(THFieldDef{..}) =-  def { dbFieldName = fromMaybe dbFieldName $ psDbFieldName settings-      , exprName = fromMaybe exprName $ psExprName settings-      , embeddedDef = psEmbeddedDef settings+applyFieldSettings PSFieldDef{..} def@(THFieldDef{..}) =+  def { thDbFieldName = fromMaybe thDbFieldName psDbFieldName+      , thExprName = fromMaybe thExprName psExprName+      , thDbTypeName = psDbTypeName+      , thEmbeddedDef = psEmbeddedDef       }  applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef-applyEmbeddedSettings settings def@(THEmbeddedDef{..}) =-  def { dbEmbeddedName = fromMaybe dbEmbeddedName $ psDbEmbeddedName settings-      , embeddedFields = maybe embeddedFields (f embeddedFields) $ psEmbeddedFields settings+applyEmbeddedSettings PSEmbeddedDef{..} def@(THEmbeddedDef{..}) =+  def { thDbEmbeddedName = fromMaybe thDbEmbeddedName psDbEmbeddedName+      , thEmbeddedFields = maybe thEmbeddedFields (f thEmbeddedFields) psEmbeddedFields       } where-  f = foldr $ replaceOne "field" psFieldName fieldName applyFieldSettings+  f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings  mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]-mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (psUniqueFields uniqueDef) [0..] where-  findField name = findOne "field" id fieldName name $ thConstrFields cDef-  uniqueDef = findOne "unique" id psUniqueName (thUniqueKeyName uniqueKey) $ thConstrUniques cDef-  setSelector f i = f {exprName = mkExprSelectorName style dName (thUniqueKeyConstrName uniqueKey) (fieldName f) i}+mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (thUniqueFields uniqueDef) [0..] where+  findField name = findOne "field" id thFieldName name $ thConstrFields cDef+  uniqueDef = findOne "unique" id thUniqueName (thUniqueKeyName uniqueKey) $ thConstrUniques cDef+  setSelector f i = f {thExprName = mkExprSelectorName style dName (thUniqueKeyConstrName uniqueKey) (thFieldName f) i}  notUniqueBy :: Eq b => (a -> b) -> [a] -> [b] notUniqueBy f xs = let xs' = map f xs in nub $ xs' \\ nub xs'@@ -265,41 +268,47 @@ validateEntity def = do   let constrs = thConstructors def   assertUnique thPhantomConstrName constrs "constructor phantom name"-  assertUnique dbConstrName constrs "constructor db name"+  assertUnique thDbConstrName constrs "constructor db name"   forM_ constrs $ \cdef -> do     let fields = thConstrFields cdef     assertSpaceFree (thPhantomConstrName cdef) "constructor phantom name"-    assertUnique exprName fields "expr field name in a constructor"-    assertUnique dbFieldName fields "db field name in a constructor"-    forM_ fields $ \fdef -> assertSpaceFree (exprName fdef) "field expr name"-    case filter (\(PSUniqueDef _ cfields) -> null cfields) $ thConstrUniques cdef of+    assertUnique thExprName fields "expr field name in a constructor"+    assertUnique thDbFieldName fields "db field name in a constructor"+    mapM_ validateField fields+    case filter (\(THUniqueDef _ _ uFields) -> null uFields) $ thConstrUniques cdef of       [] -> return ()       ys -> fail $ "Constraints must have at least one field: " ++ show ys     when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $-      fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (dataName def)+      fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def)          -- check that unique keys = [] for multiple constructor datatype   if length constrs > 1 && not (null $ thUniqueKeys def)-    then fail $ "Unique keys may exist only for datatypes with single constructor: " ++ show (dataName def)+    then fail $ "Unique keys may exist only for datatypes with single constructor: " ++ show (thDataName def)     else -- check that all unique keys reference existing uniques-         let uniqueNames = map psUniqueName $ thConstrUniques $ head constrs+         let uniqueNames = map thUniqueName $ thConstrUniques $ head constrs          in  forM_ (thUniqueKeys def) $ \cKey -> unless (thUniqueKeyName cKey `elem` uniqueNames) $-             fail $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (dataName def)+             fail $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (thDataName def)   -- check that if unique keys = [] there is auto key   when (null (thUniqueKeys def) && isNothing (thAutoKey def)) $-    fail $ "A datatype must have either an auto key or unique keys: " ++ show (dataName def)+    fail $ "A datatype must have either an auto key or unique keys: " ++ show (thDataName def)   -- check that only one of the keys is default   let defaults = maybe False thAutoKeyIsDef (thAutoKey def) : map thUniqueKeyIsDef (thUniqueKeys def)   when (length (filter id defaults) /= 1) $-    fail $ "A datatype must have exactly one default key: " ++ show (dataName def)+    fail $ "A datatype must have exactly one default key: " ++ show (thDataName def)   return def+  +validateField :: THFieldDef -> Either String ()+validateField fDef = do+  assertSpaceFree (thExprName fDef) "field expr name"+  when (isJust (thDbTypeName fDef) && isJust (thEmbeddedDef fDef)) $+    fail $ "A field may not have both type and embeddedType: " ++ show (thFieldName fDef)  validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef validateEmbedded def = do-  let fields = embeddedFields def-  assertUnique exprName fields "expr field name in an embedded datatype"-  assertUnique dbFieldName fields "db field name in an embedded datatype"-  forM_ fields $ \fdef -> assertSpaceFree (exprName fdef) "field expr name"+  let fields = thEmbeddedFields def+  assertUnique thExprName fields "expr field name in an embedded datatype"+  assertUnique thDbFieldName fields "db field name in an embedded datatype"+  mapM_ validateField fields   return def  mkTHEntityDefWith :: NamingStyle -> Dec -> THEntityDef@@ -318,10 +327,10 @@       apply f = f dName' (nameBase name) cNum      mkField :: String -> StrictType -> Int -> THFieldDef-    mkField cName (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) (apply mkNormalExprFieldName) t Nothing where+    mkField cName (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) Nothing (apply mkNormalExprFieldName) t Nothing where       apply f = f dName' cName cNum fNum     mkVarField :: String -> VarStrictType -> Int -> THFieldDef-    mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) (apply mkExprFieldName) t Nothing where+    mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (apply mkExprFieldName) t Nothing where       apply f = f dName' cName cNum fName' fNum       fName' = nameBase fName mkTHEntityDefWith _ _ = error "Only datatypes can be processed"@@ -340,10 +349,10 @@     _ -> error $ "An embedded datatype must have exactly one constructor: " ++ show dName      mkField :: String -> StrictType -> Int -> THFieldDef-  mkField cName' (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) (mkNormalExprSelectorName dName' cName' fNum) t Nothing where+  mkField cName' (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) Nothing (mkNormalExprSelectorName dName' cName' fNum) t Nothing where     apply f = f dName' cName' 0 fNum   mkVarField :: String -> VarStrictType -> Int -> THFieldDef-  mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) (mkExprSelectorName dName' cName' fName' fNum) t Nothing where+  mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (mkExprSelectorName dName' cName' fName' fNum) t Nothing where     apply f = f dName' cName' 0 fName' fNum     fName' = nameBase fName mkTHEmbeddedDefWith _ _ = error "Only datatypes can be processed"@@ -360,12 +369,28 @@ -- You can create your own embedded types and adjust the fields names of an existing embedded type individually for any place where it is used. --  -- Unless the property is marked as mandatory, it can be omitted. In this case value created by the NamingStyle will be used.--- The example below has all properties set explicitly. -- -- @ --data Settable = First {foo :: String, bar :: Int} deriving (Eq, Show) --+--    \-- The declaration with defaulted names+-- --mkPersist defaultCodegenConfig [groundhog|+--entity: Settable                       # If we did not want to add a constraint, this line would be enough+--keys:+--  - name: someconstraint+--constructors:+--  - name: First+--    uniques:+--      - name: someconstraint+--        fields: [foo, bar]+-- |]+-- @+--+-- Which is equivalent to the example below that has all properties set explicitly.+--+-- @+--mkPersist defaultCodegenConfig [groundhog| --definitions:                           # First level key whose value is a list of definitions. It can be considered an optional header. --                                       # The list elements start with hyphen+space. Keys are separated from values by a colon+space. See full definition at http://yaml.org/spec/1.2/spec.html. --  - entity: Settable                   # Mandatory. Entity datatype name@@ -386,33 +411,21 @@ --        phantomName: FooBarConstructor # Constructor phantom type name used to guarantee type safety --        dbName: First                  # Name of constructor table which is created only for datatypes with multiple constructors --        fields:                        # List of constructor fields. If you don't change a field, you can omit it---          - name: foo+--          - name: foo                  # The name as in constructor record. If constructor is not a record, the name is created by 'mkNormalFieldName'. For example, the fields in constructor SomeConstr would have names someConstr0 and someConstr1 by default. --            dbName: foo                # Column name---            exprName: FooField         # Name of a field used in expressions+--            thExprName: FooField       # Name of a field used in expressions+--            \# type: varchar            # This would result in having field type DbOther \"varchar\" instead of DbString. Value of this attribute will be used by DB backend for migration --          - name: bar --            dbName: bar---            exprName: BarField+--            thExprName: BarField+--                                       # For some databases \"type: integer\" would be appropriate --        uniques: --          - name: someconstraint+--            type: constraint           # The type can be either \"constraint\" or \"index\" --            fields: [foo, bar]         # List of constructor parameter names. Not DB names(!) -- |] -- @ ----- which is equivalent to the declaration with defaulted names------ @---mkPersist defaultCodegenConfig [groundhog|---entity: Settable                       # If we did not want to add a constraint, this line would be enough---keys:---  - name: someconstraint---constructors:---  - name: First---    uniques:---      - name: someconstraint---        fields: [foo, bar]--- |]--- @--- -- This is an example of embedded datatype usage. -- -- @@@ -463,8 +476,20 @@ groundhogFile = quoteFile groundhog  parseDefinitions :: String -> Q Exp-parseDefinitions s = either fail lift result where-  result = decodeEither $ pack s :: Either String PersistDefinitions+parseDefinitions s = do+  result <- runIO $ decodeHelper (Y.decode $ pack s)+  case result of+    Left err -> case err of+      InvalidYaml (Just (Y.YamlParseException problem context mark)) -> fail $ unlines+        [ "YAML parse error: " ++ problem+        , "Context: " ++ context+        , "At line: " ++ show (Y.yamlLine mark)+        , lines s !! Y.yamlLine mark+        , replicate (Y.yamlColumn mark) ' ' ++ "^"+        ]+      _ -> fail $ show err+    Right (Left err) -> fail err+    Right (Right result') -> lift (result' :: PersistDefinitions)  mkEntityDecs :: THEntityDef -> Q [Dec] mkEntityDecs def = do

@@ -34,22 +34,22 @@ mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedPersistFieldInstance def = do
   let types = map extractType $ thEmbeddedTypeParams def
-  let embedded = foldl AppT (ConT (embeddedName def)) types
+  let embedded = foldl AppT (ConT (thEmbeddedName def)) types
 
   persistName' <- do
     v <- newName "v"
     let mkLambda t = [|undefined :: $(forallT (thEmbeddedTypeParams def) (cxt []) [t| $(return embedded) -> $(return t) |]) |]
     let paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types
     let fullEmbeddedName = case null types of
-         True  -> [| $(stringE $ dbEmbeddedName def) |]
-         False -> [| $(stringE $ dbEmbeddedName def) ++ [delim] ++ $(paramNames) |]
+         True  -> [| $(stringE $ thDbEmbeddedName def) |]
+         False -> [| $(stringE $ thDbEmbeddedName def) ++ [delim] ++ $(paramNames) |]
     let body = normalB $ fullEmbeddedName
     let pat = if null types then wildP else varP v
     funD 'persistName $ [ clause [pat] body [] ]
 
   toPersistValues' <- do
-    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, fieldType f)) $ embeddedFields def
-    let pat = conP (embeddedConstructorName def) $ map (varP . fst) vars
+    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, thFieldType f)) $ thEmbeddedFields def
+    let pat = conP (thEmbeddedConstructorName def) $ map (varP . fst) vars
     proxy <- newName "p"
     (lastPrims, fields) <- spanM (isPrim . snd) $ reverse vars
     let lastPrims' = map (\(x, _) -> [| toPrimitivePersistValue $(varE proxy) $(varE x) |]) $ reverse $ lastPrims
@@ -70,7 +70,7 @@   fromPersistValues' <- do
     xs <- newName "xs"
     failureName <- newName "failure"
-    (isFailureUsed, body) <- mkFromPersistValues failureName xs (embeddedConstructorName def) (embeddedFields def)
+    (isFailureUsed, body) <- mkFromPersistValues failureName xs (thEmbeddedConstructorName def) (thEmbeddedFields def)
     let failureBody = normalB [| (\a -> fail (failMessage a $(varE xs)) >> return (a, [])) undefined |]
         failureFunc = funD failureName [clause [] failureBody []]
         locals = if isFailureUsed then [failureFunc] else []
@@ -80,18 +80,20 @@     v <- newName "v"
     let mkField fNum f = do
         a <- newName "a"
-        let fname = dbFieldName f
-        let nvar = if hasFreeVars (fieldType f)
-             then let pat = conP (embeddedConstructorName def) $ replicate fNum wildP ++ [varP a] ++ replicate (length (embeddedFields def) - fNum - 1) wildP
-                  in caseE (varE v) $ [match pat (normalB $ varE a) []]
-             else [| undefined :: $(return $ fieldType f) |]
-        case embeddedDef f of
-          Nothing -> [| (fname, dbType $nvar) |]
-          Just e  -> [| (fname, applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar )) |]
+        let fname = thDbFieldName f
+            nvar = if hasFreeVars (thFieldType f)
+              then let pat = conP (thEmbeddedConstructorName def) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thEmbeddedFields def) - fNum - 1) wildP
+                   in caseE (varE v) $ [match pat (normalB $ varE a) []]
+              else [| undefined :: $(return $ thFieldType f) |]
+            typ = case (thEmbeddedDef f, thDbTypeName f) of
+              (Just e, _) -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |]
+              (_, Just name) -> [| DbOther $(lift name) |]
+              _ -> [| dbType $nvar |]
+        [| (fname, $typ) |]
     let pat = if null $ thEmbeddedTypeParams def then wildP else varP v
-    funD 'dbType $ [ clause [pat] (normalB [| DbEmbedded $ EmbeddedDef False $(listE $ zipWith mkField [0..] (embeddedFields def)) |]) [] ]
+    funD 'dbType $ [ clause [pat] (normalB [| DbEmbedded $ EmbeddedDef False $(listE $ zipWith mkField [0..] (thEmbeddedFields def)) |]) [] ]
 
-  let context = paramsContext (thEmbeddedTypeParams def) (embeddedFields def)
+  let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)
   let decs = [persistName', toPersistValues', fromPersistValues', dbType']
   return $ [InstanceD context (AppT (ConT ''PersistField) embedded) decs]
 
@@ -117,7 +119,7 @@     mkArg proxy (fname, t) = isPrim t >>= \isP -> (if isP then [| fromPrimitivePersistValue $(varE proxy) $(varE fname) |] else (varE fname))
     in do
       proxy <- newName "p"
-      vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, fieldType f)) fieldDefs
+      vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, thFieldType f)) fieldDefs
       anyPrim <- liftM or $ mapM (isPrim . snd) vars
       let failure = match wildP (normalB $ varE failureName) []
       let result = foldl (\a f -> appE a $ mkArg proxy f) (conE constrName) vars
@@ -128,7 +130,7 @@ mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> Cxt -> Q [Dec]
 mkPurePersistFieldInstance dataType cName fDefs context = do
   toPurePersistValues' <- do
-    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, fieldType f)) fDefs
+    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, thFieldType f)) fDefs
     let pat = conP cName $ map (varP . fst) vars
     proxy <- newName "p"
     let body = mkToPurePersistValues proxy vars
@@ -158,7 +160,7 @@       let failureBody = normalB [| (\a -> error (failMessage a $(varE xs)) `asTypeOf` (a, [])) undefined |]
       failureName <- newName "failure"
       proxy <- newName "p"
-      vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, fieldType f)) fDefs
+      vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, thFieldType f)) fDefs
       let failure = match wildP (normalB $ varE failureName) []
       let result = foldl (\a f -> appE a $ mkArg proxy f) (conE cName) vars
       (isFailureUsed, start) <- goPrim xs vars result failure proxy
@@ -172,17 +174,17 @@ mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedPurePersistFieldInstance def = do
   let types = map extractType $ thEmbeddedTypeParams def
-  let embedded = foldl AppT (ConT (embeddedName def)) types
-  let fDefs = embeddedFields def
+  let embedded = foldl AppT (ConT (thEmbeddedName def)) types
+  let fDefs = thEmbeddedFields def
   context <- paramsPureContext (thEmbeddedTypeParams def) fDefs
   case context of
     Nothing -> return []
-    Just context' -> mkPurePersistFieldInstance embedded (embeddedConstructorName def) fDefs context'
+    Just context' -> mkPurePersistFieldInstance embedded (thEmbeddedConstructorName def) fDefs context'
 
 mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec]
 mkAutoKeyPersistFieldInstance def = case thAutoKey def of
   Just autoKey -> do
-    let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+    let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
     keyType <- [t| Key $(return entity) BackendSpecific |]
     
     persistName' <- do
@@ -204,7 +206,7 @@ mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
 mkAutoKeyPrimitivePersistFieldInstance def = case thAutoKey def of
   Just autoKey -> do
-    let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+    let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
     keyType <- [t| Key $(return entity) BackendSpecific |]
     let conName = mkName $ thAutoKeyConstrName autoKey
     toPrim' <- do
@@ -220,7 +222,7 @@ 
 mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysIsUniqueInstances def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   let constr = head $ thConstructors def
   forM (thUniqueKeys def) $ \unique -> do
     uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
@@ -228,13 +230,13 @@       typ <- conT $ mkName $ thPhantomConstrName constr
       return $ TySynInstD ''UniqueConstr [uniqKeyType] typ
     extractUnique' <- do
-      uniqueFields <- mapM (\f -> newName "x" >>= \x -> return (fieldName f, x)) $ thUniqueKeyFields unique
-      let mkFieldPat f = maybe wildP varP $ lookup (fieldName f) uniqueFields
+      uniqueFields <- mapM (\f -> newName "x" >>= \x -> return (thFieldName f, x)) $ thUniqueKeyFields unique
+      let mkFieldPat f = maybe wildP varP $ lookup (thFieldName f) uniqueFields
       let pat = conP (thConstrName constr) $ map mkFieldPat $ thConstrFields constr
       let body = foldl (\expr f -> [| $expr $(varE $ snd f) |]) (conE $ mkName $ thUniqueKeyConstrName unique) uniqueFields
       funD 'extractUnique [clause [pat] (normalB body) []]
     uniqueNum' <- do
-      let index = findIndex (\u -> thUniqueKeyName unique == psUniqueName u) $ thConstrUniques constr
+      let index = findIndex (\u -> thUniqueKeyName unique == thUniqueName u) $ thConstrUniques constr
       let uNum = maybe (error $ "mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " ++ thUniqueKeyName unique) id index
       funD 'uniqueNum [clause [wildP] (normalB [| uNum |]) []]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
@@ -242,7 +244,7 @@ 
 mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysEmbeddedInstances def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   liftM concat $ forM (filter thUniqueKeyMakeEmbedded $ thUniqueKeys def) $ \unique -> do
     uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
@@ -250,7 +252,7 @@   
 mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysPersistFieldInstances def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   forM (thUniqueKeys def) $ \unique -> do
     uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
 
@@ -263,11 +265,13 @@     dbType' <- do
       a <- newName "a"
       let mkField f = do
-          let fname = dbFieldName f
-          let nvar = [| undefined :: $(return $ fieldType f) |]
-          case embeddedDef f of
-            Nothing -> [| (fname, dbType $nvar) |]
-            Just e  -> [| (fname, applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar )) |]
+          let fname = thDbFieldName f
+              nvar = [| undefined :: $(return $ thFieldType f) |]
+              typ = case (thEmbeddedDef f, thDbTypeName f) of
+                (Just e, _)  -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |]
+                (_, Just name) -> [| DbOther $(lift name) |]
+                _ -> [| dbType $nvar |]
+          [| (fname, $typ) |]
       let embedded = [| EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique) |]
       let body = [| DbEntity (Just ($embedded, $(lift $ thUniqueKeyName unique))) $ entityDef ((undefined :: Key v a -> v) $(varE a)) |]
       funD 'dbType [clause [varP a] (normalB body) []]
@@ -277,13 +281,13 @@     
 mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysPrimitiveOrPurePersistFieldInstances def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   liftM concat $ forM (thUniqueKeys def) $ \unique -> do
     uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
     let conName = mkName $ thUniqueKeyConstrName unique
     isUniquePrim <- if (length $ thUniqueKeyFields unique) == 1
-      then isPrim $ fieldType $ head $ thUniqueKeyFields unique
+      then isPrim $ thFieldType $ head $ thUniqueKeyFields unique
       else return False
     if isUniquePrim
       then do
@@ -298,7 +302,7 @@ 
 mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
 mkKeyEqShowInstances def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   let mkShowInstance typ cName fieldsNum = do
       showsPrec' <- do
         p <- newName "p"
@@ -339,19 +343,19 @@ mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedInstance def = do
   let types = map extractType $ thEmbeddedTypeParams def
-  let embedded = foldl AppT (ConT (embeddedName def)) types
-  let context = paramsContext (thEmbeddedTypeParams def) (embeddedFields def)
-  mkEmbeddedInstance' embedded (embeddedFields def) context
+  let embedded = foldl AppT (ConT (thEmbeddedName def)) types
+  let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)
+  mkEmbeddedInstance' embedded (thEmbeddedFields def) context
   
 mkEmbeddedInstance' :: Type -> [THFieldDef] -> Cxt -> Q [Dec]
 mkEmbeddedInstance' dataType fDefs context = do
   selector' <- do
     fParam <- newName "f"
-    let mkField field = ForallC [] ([EqualP (VarT fParam) (fieldType field)]) $ NormalC (mkName $ exprName field) []
+    let mkField field = ForallC [] ([EqualP (VarT fParam) (thFieldType field)]) $ NormalC (mkName $ thExprName field) []
     return $ DataInstD [] ''Selector [dataType, VarT fParam] (map mkField fDefs) []
 
   selectorNum' <- do
-    let mkClause fNum field = clause [conP (mkName $ exprName field) []] (normalB $ lift fNum) []
+    let mkClause fNum field = clause [conP (mkName $ thExprName field) []] (normalB $ lift fNum) []
     let clauses = zipWith mkClause [0 :: Int ..] fDefs
     funD 'selectorNum clauses
 
@@ -360,7 +364,7 @@ 
 mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
 mkEntityPhantomConstructors def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   forM (thConstructors def) $ \c -> do
     v <- newName "v"
     let name = mkName $ thPhantomConstrName c
@@ -372,12 +376,12 @@ mkEntityPhantomConstructorInstances def = sequence $ zipWith f [0..] $ thConstructors def where
   f :: Int -> THConstructorDef -> Q Dec
   f cNum c = instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName $ thPhantomConstrName c)) [phantomConstrName', phantomConstrNum'] where
-    phantomConstrName' = funD 'phantomConstrName [clause [wildP] (normalB $ stringE $ dbConstrName c) []]
+    phantomConstrName' = funD 'phantomConstrName [clause [wildP] (normalB $ stringE $ thDbConstrName c) []]
     phantomConstrNum' = funD 'phantomConstrNum [clause [wildP] (normalB $ [| cNum |]) []]
 
 mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]
 mkEntityUniqueKeysPhantoms def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
   forM (thUniqueKeys def) $ \u -> do
     v <- newName "v"
     let name = mkName $ thUniqueKeyPhantomName u
@@ -387,7 +391,7 @@     
 mkPersistEntityInstance :: THEntityDef -> Q [Dec]
 mkPersistEntityInstance def = do
-  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def
 
   key' <- do
     uParam <- newName "u"
@@ -399,11 +403,9 @@     uniques <- forM (thUniqueKeys def) $ \unique -> do
       let cDef = head $ thConstructors def
       uniqType <- [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName unique) |]
-      let uniqFieldNames = case filter ((== thUniqueKeyName unique) . psUniqueName) $ thConstrUniques cDef of
-            [a] -> psUniqueFields a
-            _   -> error $ "Unique key must correspond to one unique definition: " ++ thUniqueKeyName unique
-      let uniqFields = concat $ flip map uniqFieldNames $ \name -> (filter ((== name) . fieldName) $ thConstrFields cDef)
-      let uniqFields' = map (\f -> (NotStrict, fieldType f)) uniqFields
+      let uniqFieldNames = thUniqueFields $ findOne "unique" thUniqueKeyName thUniqueName unique $ thConstrUniques cDef
+      let uniqFields = concat $ flip map uniqFieldNames $ \name -> (filter ((== name) . thFieldName) $ thConstrFields cDef)
+      let uniqFields' = map (\f -> (NotStrict, thFieldType f)) uniqFields
       return $ ForallC [] [EqualP (VarT uParam) uniqType] $ NormalC (mkName $ thUniqueKeyConstrName unique) uniqFields'
     return $ DataInstD [] ''Key [entity, VarT uParam] (autoKey ++ uniques) []
 
@@ -424,7 +426,7 @@   fields' <- do
     cParam <- newName "c"
     fParam <- newName "f"
-    let mkField name field = ForallC [] [EqualP (VarT cParam) (ConT name), EqualP (VarT fParam) (fieldType field)] $ NormalC (mkName $ exprName field) []
+    let mkField name field = ForallC [] [EqualP (VarT cParam) (ConT name), EqualP (VarT fParam) (thFieldType field)] $ NormalC (mkName $ thExprName field) []
     let f cdef = map (mkField $ mkName $ thPhantomConstrName cdef) $ thConstrFields cdef
     let constrs = concatMap f $ thConstructors def
     return $ DataInstD [] ''Field [entity, VarT cParam, VarT fParam] constrs []
@@ -436,34 +438,36 @@     let typeParams' = listE $ map (\t -> [| dbType ($(mkLambda t) $(varE v)) |]) types
     let mkField c fNum f = do
         a <- newName "a"
-        let fname = dbFieldName f
-        let nvar = if hasFreeVars (fieldType f)
-             then let pat = conP (thConstrName c) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thConstrFields c) - fNum - 1) wildP
-                      wildClause = if length (thConstructors def) > 1 then [match wildP (normalB [| undefined |]) []] else []
-                  in caseE (varE v) $ [match pat (normalB $ varE a) []] ++ wildClause
-             else [| undefined :: $(return $ fieldType f) |]
-        case embeddedDef f of
-          Nothing -> [| (fname, dbType $nvar) |]
-          Just e  -> [| (fname, applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar )) |]
+        let fname = thDbFieldName f
+            nvar = if hasFreeVars (thFieldType f)
+              then let pat = conP (thConstrName c) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thConstrFields c) - fNum - 1) wildP
+                       wildClause = if length (thConstructors def) > 1 then [match wildP (normalB [| undefined |]) []] else []
+                   in caseE (varE v) $ [match pat (normalB $ varE a) []] ++ wildClause
+              else [| undefined :: $(return $ thFieldType f) |]
+            typ = case (thEmbeddedDef f, thDbTypeName f) of
+              (Just e, _)  -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |]
+              (_, Just name) -> [| DbOther $(lift name) |]
+              _ -> [| dbType $nvar |]
+        [| (fname, $typ) |]
     let constrs = listE $ zipWith mkConstructorDef [0..] $ thConstructors def
         mkConstructorDef cNum c@(THConstructorDef _ _ name keyName params conss) = [| ConstructorDef cNum name keyName $(listE $ map snd fields) $(listE $ map mkConstraint conss) |] where
-          fields = zipWith (\i f -> (fieldName f, mkField c i f)) [0..] params
-          mkConstraint (PSUniqueDef uName uFields) = [| UniqueDef uName $(listE $ map getField uFields) |]
+          fields = zipWith (\i f -> (thFieldName f, mkField c i f)) [0..] params
+          mkConstraint (THUniqueDef uName uType uFields) = [| UniqueDef uName uType $(listE $ map getField uFields) |]
           getField fName = case lookup fName fields of
             Just f -> f
             Nothing -> error $ "Field name " ++ show fName ++ " declared in unique not found"
     
     let paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types
     let fullEntityName = case null types of
-         True  -> [| $(stringE $ dbEntityName def) |]
-         False -> [| $(stringE $ dbEntityName def) ++ [delim] ++ $(paramNames) |]
+         True  -> [| $(stringE $ thDbEntityName def) |]
+         False -> [| $(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames) |]
 
     let body = normalB [| EntityDef $fullEntityName $typeParams' $constrs |]
     let pat = if null $ thTypeParams def then wildP else varP v
     funD 'entityDef $ [ clause [pat] body [] ]
 
   toEntityPersistValues' <- liftM (FunD 'toEntityPersistValues) $ forM (zip [0..] $ thConstructors def) $ \(cNum, c) -> do
-    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, fieldType f)) $ thConstrFields c
+    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, thFieldType f)) $ thConstrFields c
     let pat = conP (thConstrName c) $ map (varP . fst) vars
     proxy <- newName "p"
     (lastPrims, fields) <- spanM (isPrim . snd) $ reverse vars
@@ -501,25 +505,26 @@     mkClause cNum cdef | not (hasConstraints cdef) = clause [wildP, conP (thConstrName cdef) pats] (normalB [| (cNum, []) |]) [] where
       pats = map (const wildP) $ thConstrFields cdef
     mkClause cNum cdef = do
-      let allConstrainedFields = concatMap psUniqueFields $ thConstrUniques cdef
-      vars <- mapM (\f -> newName "x" >>= \x -> return $ if fieldName f `elem` allConstrainedFields then Just (x, fieldType f) else Nothing) $ thConstrFields cdef
+      let allConstrainedFields = concatMap thUniqueFields $ thConstrUniques cdef
+      vars <- mapM (\f -> newName "x" >>= \x -> return $ if thFieldName f `elem` allConstrainedFields then Just (x, thFieldType f) else Nothing) $ thConstrFields cdef
       let pat = conP (thConstrName cdef) $ map (maybe wildP (varP . fst)) vars
       proxy <- newName "p"
-      let body = normalB $ [| (cNum, $(listE $ map (\(PSUniqueDef uName fnames) -> [| (uName, $result []) |] ) $ thConstrUniques cdef)) |]
+      let body = normalB $ [| (cNum, $(listE $ map (\(THUniqueDef uName _ fnames) -> [| (uName, $result) |] ) $ thConstrUniques cdef)) |]
           result = mkToPurePersistValues proxy (catMaybes vars)
       clause [varP proxy, pat] body []
     in funD 'getUniques clauses
 
   entityFieldChain' <- let
-    fieldNames = thConstructors def >>= thConstrFields
-    clauses = map (\f -> mkChain f >>= \(fArg, body) -> clause [asP fArg $ conP (mkName $ exprName f) []] (normalB body) []) fieldNames
+    thFieldNames = thConstructors def >>= thConstrFields
+    clauses = map (\f -> mkChain f >>= \(fArg, body) -> clause [asP fArg $ conP (mkName $ thExprName f) []] (normalB body) []) thFieldNames
     mkChain f = do
         fArg <- newName "f"
         let nvar = [| (undefined :: Field v c a -> a) $(varE fArg) |]
-        let typ = case embeddedDef f of
-              Nothing -> [| dbType $nvar |]
-              Just e  -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |]
-        let body = [| (($(lift $ dbFieldName f), $typ), []) |]
+            typ = case (thEmbeddedDef f, thDbTypeName f) of
+              (Just e, _)  -> [| applyEmbeddedDbTypeSettings $(lift e) (dbType $nvar ) |]
+              (_, Just name) -> [| DbOther $(lift name) |]
+              _ -> [| dbType $nvar |]
+        let body = [| (($(lift $ thDbFieldName f), $typ), []) |]
         return (fArg, body)
     in funD 'entityFieldChain clauses
 
@@ -545,7 +550,7 @@ mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
 mkEntityPersistFieldInstance def = do
   let types = map extractType $ thTypeParams def
-  let entity = foldl AppT (ConT (dataName def)) types
+  let entity = foldl AppT (ConT (thDataName def)) types
   
   persistName' <- do
     v <- newName "v"
@@ -553,8 +558,8 @@     
     let paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types
     let fullEntityName = case null types of
-         True  -> [| $(stringE $ dbEntityName def) |]
-         False -> [| $(stringE $ dbEntityName def) ++ [delim] ++ $(paramNames) |]
+         True  -> [| $(stringE $ thDbEntityName def) |]
+         False -> [| $(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames) |]
     let body = normalB $ fullEntityName
     let pat = if null types then wildP else varP v
     funD 'persistName $ [ clause [pat] body [] ]
@@ -601,13 +606,13 @@       Right k -> ([| toSinglePersistValueUnique $u |], [| fromSinglePersistValueUnique $u |]) where
         u = conE $ mkName $ thUniqueKeyPhantomName k
     types = map extractType $ thTypeParams def
-    entity = foldl AppT (ConT (dataName def)) types
+    entity = foldl AppT (ConT (thDataName def)) types
     context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
 
 mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]
 mkEntityNeverNullInstance def = do
   let types = map extractType $ thTypeParams def
-  let entity = foldl AppT (ConT (dataName def)) types
+  let entity = foldl AppT (ConT (thDataName def)) types
   let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
   isOne <- isDefaultKeyOneColumn def
   return $ if isOne
@@ -617,8 +622,8 @@ mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]
 mkMigrateFunction name defs = do
   let (normal, polymorhpic) = partition (null . thTypeParams) defs
-  forM_ polymorhpic $ \def -> report False $ "Datatype " ++ show (dataName def) ++ " will not be migrated automatically by function " ++ name ++ " because it has type parameters"
-  let body = doE $ map (\def -> noBindS [| migrate (undefined :: $(conT $ dataName def)) |]) normal
+  forM_ polymorhpic $ \def -> report False $ "Datatype " ++ show (thDataName def) ++ " will not be migrated automatically by function " ++ name ++ " because it has type parameters"
+  let body = doE $ map (\def -> noBindS [| migrate (undefined :: $(conT $ thDataName def)) |]) normal
   sig <- sigD (mkName name) [t| PersistBackend m => Migration m |]
   func <- funD (mkName name) [clause [] (normalB body) []]
   return [sig, func]
@@ -626,7 +631,7 @@ isDefaultKeyOneColumn :: THEntityDef -> Q Bool
 isDefaultKeyOneColumn def = either (const $ return True) checkUnique $ getDefaultKey def where
   checkUnique unique = if (length $ thUniqueKeyFields unique) == 1
-    then isPrim $ fieldType $ head $ thUniqueKeyFields unique
+    then isPrim $ thFieldType $ head $ thUniqueKeyFields unique
     else return False
 
 getDefaultKey :: THEntityDef -> Either THAutoKeyDef THUniqueKeyDef
@@ -642,13 +647,13 @@   -- all datatype fields also must be instances of PersistField
   -- if Maybe is applied to a type param, the param must be also an instance of NeverNull
   -- so that (Maybe param) is an instance of PersistField
-  maybys = nub $ fields >>= insideMaybe . fieldType
+  maybys = nub $ fields >>= insideMaybe . thFieldType
 
 paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe Cxt)
 paramsPureContext types fields = do
   let isValidType (VarT _) = return True
       isValidType t = isPrim t
-  invalid <- filterM (liftM not . isValidType . fieldType) fields
+  invalid <- filterM (liftM not . isValidType . thFieldType) fields
   return $ case invalid of
     [] -> Just $ classPred ''PurePersistField params ++ classPred ''PrimitivePersistField maybys ++ classPred ''NeverNull maybys where
           params = map extractType types
@@ -656,7 +661,7 @@           -- all datatype fields also must be instances of PersistField
           -- if Maybe is applied to a type param, the param must be also an instance of NeverNull
           -- so that (Maybe param) is an instance of PersistField
-          maybys = nub $ fields >>= insideMaybe . fieldType
+          maybys = nub $ fields >>= insideMaybe . thFieldType
     _  -> Nothing
 
 extractType :: TyVarBndr -> Type

@@ -7,6 +7,7 @@   , THEmbeddedDef(..)
   , THConstructorDef(..)
   , THFieldDef(..)
+  , THUniqueDef(..)
   , THUniqueKeyDef(..)
   , THAutoKeyDef(..)
   , PSEntityDef(..)
@@ -19,6 +20,7 @@   , PSAutoKeyDef(..)
   ) where
 
+import Database.Groundhog.Core (UniqueType(..))
 import Database.Groundhog.Generic (PSEmbeddedFieldDef(..))
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
@@ -31,8 +33,8 @@ -- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq)
 
 data THEntityDef = THEntityDef {
-    dataName :: Name -- SomeData
-  , dbEntityName :: String  -- SQLSomeData
+    thDataName :: Name -- SomeData
+  , thDbEntityName :: String  -- SQLSomeData
   , thAutoKey :: Maybe THAutoKeyDef
   , thUniqueKeys :: [THUniqueKeyDef]
   , thTypeParams :: [TyVarBndr]
@@ -45,30 +47,37 @@ } deriving Show
 
 data THEmbeddedDef = THEmbeddedDef {
-    embeddedName :: Name
-  , embeddedConstructorName :: Name
-  , dbEmbeddedName :: String -- used only to set polymorphic part of name of its container
+    thEmbeddedName :: Name
+  , thEmbeddedConstructorName :: Name
+  , thDbEmbeddedName :: String -- used only to set polymorphic part of name of its container
   , thEmbeddedTypeParams :: [TyVarBndr]
-  , embeddedFields :: [THFieldDef]
+  , thEmbeddedFields :: [THFieldDef]
 } deriving Show
 
 data THConstructorDef = THConstructorDef {
     thConstrName    :: Name -- U2
   , thPhantomConstrName :: String -- U2Constructor
-  , dbConstrName    :: String -- SQLU2
+  , thDbConstrName    :: String -- SQLU2
   , thDbAutoKeyName :: Maybe String -- u2_id
   , thConstrFields  :: [THFieldDef]
-  , thConstrUniques :: [PSUniqueDef]
+  , thConstrUniques :: [THUniqueDef]
 } deriving Show
 
 data THFieldDef = THFieldDef {
-    fieldName :: String -- bar
-  , dbFieldName :: String -- SQLbar
-  , exprName :: String -- BarField
-  , fieldType :: Type
-  , embeddedDef :: Maybe [PSEmbeddedFieldDef]
+    thFieldName :: String -- bar
+  , thDbFieldName :: String -- SQLbar
+  , thDbTypeName :: Maybe String -- inet, NUMERIC(5, 2), VARCHAR(50)
+  , thExprName :: String -- BarField
+  , thFieldType :: Type
+  , thEmbeddedDef :: Maybe [PSEmbeddedFieldDef]
 } deriving Show
 
+data THUniqueDef = THUniqueDef {
+    thUniqueName :: String
+  , thUniqueType :: UniqueType
+  , thUniqueFields :: [String]
+} deriving Show
+
 data THUniqueKeyDef = THUniqueKeyDef {
     thUniqueKeyName :: String
   , thUniqueKeyPhantomName :: String
@@ -105,12 +114,14 @@ 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 [PSEmbeddedFieldDef]
 } deriving Show
 
 data PSUniqueDef = PSUniqueDef {
     psUniqueName :: String
+  , psUniqueType :: Maybe UniqueType
   , psUniqueFields :: [String]
 } deriving Show
 
@@ -142,13 +153,17 @@   lift (PSConstructorDef {..}) = [| PSConstructorDef $(lift psConstrName) $(lift psPhantomConstrName) $(lift psDbConstrName) $(lift psDbAutoKeyName) $(lift psConstrFields) $(lift psConstrUniques) |]
 
 instance Lift PSUniqueDef where
-  lift (PSUniqueDef name fields) = [| PSUniqueDef $(lift name) $(lift fields) |]
+  lift (PSUniqueDef name typ fields) = [| PSUniqueDef $(lift name) $(lift typ) $(lift fields) |]
 
+instance Lift UniqueType where
+  lift UniqueConstraint = [| UniqueConstraint |]
+  lift UniqueIndex = [| UniqueIndex |]
+
 instance Lift PSFieldDef where
-  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psExprName) $(lift psEmbeddedDef) |]
+  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) |]
 
 instance Lift PSEmbeddedFieldDef where
-  lift (PSEmbeddedFieldDef {..}) = [| PSEmbeddedFieldDef $(lift psEmbeddedFieldName) $(lift psDbEmbeddedFieldName) $(lift psSubEmbedded) |]
+  lift (PSEmbeddedFieldDef {..}) = [| PSEmbeddedFieldDef $(lift psEmbeddedFieldName) $(lift psDbEmbeddedFieldName) $(lift psDbEmbeddedTypeName) $(lift psSubEmbedded) |]
 
 instance Lift PSUniqueKeyDef where
   lift (PSUniqueKeyDef {..}) = [| PSUniqueKeyDef $(lift psUniqueKeyName) $(lift psUniqueKeyPhantomName) $(lift psUniqueKeyConstrName) $(lift psUniqueKeyDbName) $(lift psUniqueKeyFields) $(lift psUniqueKeyMakeEmbedded) $(lift psUniqueKeyIsDef) |]
@@ -199,15 +214,23 @@   parseJSON _          = mzero
 
 instance FromJSON PSUniqueDef where
-  parseJSON (Object v) = PSUniqueDef <$> v .: "name" <*> v .: "fields"
+  parseJSON (Object v) = PSUniqueDef <$> v .: "name" <*> v .:? "type" <*> v .: "fields"
   parseJSON _          = mzero
 
+instance FromJSON UniqueType where
+  parseJSON o = do
+    x <- parseJSON o
+    case (x :: String) of
+      "constraint" -> return UniqueConstraint
+      "index" -> return UniqueIndex
+      _ -> fail "parseJSON: UniqueType must be either \"constraint\" or \"index\""
+
 instance FromJSON PSFieldDef where
-  parseJSON (Object v) = PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "exprName" <*> v .:? "embeddedType"
+  parseJSON (Object v) = PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType"
   parseJSON _          = mzero
 
 instance FromJSON PSEmbeddedFieldDef where
-  parseJSON (Object v) = PSEmbeddedFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "embeddedType"
+  parseJSON (Object v) = PSEmbeddedFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "embeddedType"
   parseJSON _          = mzero
 
 instance FromJSON PSUniqueKeyDef where

@@ -1,5 +1,5 @@ name:            groundhog-th-version:         0.1.0.3+version:         0.2.0 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -14,11 +14,11 @@ library     build-depends:   base                     >= 4         && < 5                    , bytestring               >= 0.9-                   , groundhog                >= 0.1.0     && < 0.2.0+                   , groundhog                >= 0.2.0     && < 0.3.0                    , template-haskell                    , time                     >= 1.1.4                    , containers               >= 0.2-                   , yaml                     >= 0.6.1+                   , yaml                     >= 0.8.1     exposed-modules: Database.Groundhog.TH                      Database.Groundhog.TH.Settings                      Database.Groundhog.TH.CodeGen