groundhog-th 0.7.0.1 → 0.8

raw patch · 5 files changed

+229/−202 lines, 5 filesdep ~groundhogPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: groundhog

API changes (from Hackage documentation)

Files

• Database/Groundhog/TH.hs +44/−21
• Database/Groundhog/TH/CodeGen.hs +164/−161
• Database/Groundhog/TH/Settings.hs +14/−18
• changelog +5/−0
• groundhog-th.cabal +2/−2

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, RecordWildCards #-}+{-# LANGUAGE TemplateHaskell, RecordWildCards, CPP #-}  -- | This module provides functions to generate the auxiliary structures for the user data type module Database.Groundhog.TH@@ -29,6 +29,9 @@   , applyEntitySettings   , applyEmbeddedSettings   , applyPrimitiveSettings+  -- * Helpers+  , showReadConverter+  , enumConverter   ) where  import Database.Groundhog.Core (delim, UniqueType(..))@@ -200,10 +203,7 @@   let getDecl name = do         info <- reify $ mkName name         return $ case info of-          TyConI x -> case x of-            d@DataD{}  -> d-            NewtypeD{} -> error "Newtypes are not supported"-            _ -> error $ "Unknown declaration type: " ++ name ++ " " ++ show x+          TyConI d -> d           _        -> error $ "Only datatypes can be processed: " ++ name          entities   <- forM psEntities $ \e ->@@ -270,6 +270,7 @@       , thEmbeddedDef = psEmbeddedDef       , thDefaultValue = psDefaultValue       , thReferenceParent = psReferenceParent+      , thFieldConverter = fmap mkName psFieldConverter       }  applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef@@ -282,7 +283,7 @@ applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef applyPrimitiveSettings PSPrimitiveDef{..} def@(THPrimitiveDef{..}) =   def { thPrimitiveDbName = fromMaybe thPrimitiveDbName psPrimitiveDbName-      , thPrimitiveStringEnumRepresentation = fromMaybe thPrimitiveStringEnumRepresentation psPrimitiveStringEnumRepresentation+      , thPrimitiveConverter = mkName psPrimitiveConverter       }  mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]@@ -358,10 +359,11 @@   return def  mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef-mkTHEntityDef NamingStyle{..} (DataD _ dName typeVars cons _) =-  THEntityDef dName (mkDbEntityName dName') Nothing (Just $ THAutoKeyDef (mkEntityKeyName dName') True) [] typeVars constrs where+mkTHEntityDef NamingStyle{..} dec = THEntityDef dName (mkDbEntityName dName') Nothing autokey [] typeVars constrs where+  (dName, typeVars, cons) = fromDataD dec   constrs = zipWith mkConstr [0..] cons   dName' = nameBase dName+  autokey = Just $ THAutoKeyDef (mkEntityKeyName dName') True    mkConstr cNum c = case c of     NormalC name params -> mkConstr' name $ zipWith (mkField (nameBase name)) params [0..]@@ -373,17 +375,17 @@       apply f = f dName' (nameBase name) cNum      mkField :: String -> StrictType -> Int -> THFieldDef-    mkField cName (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) Nothing (apply mkNormalExprFieldName) t Nothing Nothing Nothing where+    mkField cName (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) Nothing (apply mkNormalExprFieldName) t Nothing Nothing Nothing Nothing where       apply f = f dName' cName cNum fNum     mkVarField :: String -> VarStrictType -> Int -> THFieldDef-    mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (apply mkExprFieldName) t Nothing Nothing Nothing where+    mkVarField cName (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (apply mkExprFieldName) t Nothing Nothing Nothing Nothing where       apply f = f dName' cName cNum fName' fNum       fName' = nameBase fName-mkTHEntityDef _ _ = error "Only datatypes can be processed"  mkTHEmbeddedDef :: NamingStyle -> Dec -> THEmbeddedDef-mkTHEmbeddedDef (NamingStyle{..}) (DataD _ dName typeVars cons _) =-  THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields where+mkTHEmbeddedDef (NamingStyle{..}) dec = THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields where++  (dName, typeVars, cons) = fromDataD dec   dName' = nameBase dName      (cName, fields) = case cons of@@ -395,20 +397,32 @@     _ -> 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) Nothing (mkNormalExprSelectorName dName' cName' fNum) t Nothing Nothing Nothing where+  mkField cName' (_, t) fNum = THFieldDef (apply mkNormalFieldName) (apply mkNormalDbFieldName) Nothing (mkNormalExprSelectorName dName' cName' fNum) t Nothing Nothing Nothing Nothing where     apply f = f dName' cName' 0 fNum   mkVarField :: String -> VarStrictType -> Int -> THFieldDef-  mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (mkExprSelectorName dName' cName' fName' fNum) t Nothing Nothing Nothing where+  mkVarField cName' (fName, _, t) fNum = THFieldDef fName' (apply mkDbFieldName) Nothing (mkExprSelectorName dName' cName' fName' fNum) t Nothing Nothing Nothing Nothing where     apply f = f dName' cName' 0 fName' fNum     fName' = nameBase fName-mkTHEmbeddedDef _ _ = error "Only datatypes can be processed"  mkTHPrimitiveDef :: NamingStyle -> Dec -> THPrimitiveDef-mkTHPrimitiveDef (NamingStyle{..}) (DataD _ dName _ _ _) =-  THPrimitiveDef dName (mkDbEntityName dName') True where+mkTHPrimitiveDef (NamingStyle{..}) dec = THPrimitiveDef dName (mkDbEntityName dName') 'showReadConverter where+  dName = case dec of+#if MIN_VERSION_template_haskell(2, 11, 0)+    DataD _ dName _ _ _ _ -> dName+    NewtypeD _ dName _ _ _ _ -> dName+#else+    DataD _ dName _ _ _ -> dName+    NewtypeD _ dName _ _ _ -> dName+#endif+    _ -> error $ "Only datatypes and newtypes can be declared as primitive: " ++ show dec   dName' = nameBase dName-mkTHPrimitiveDef _ _ = error "Only datatypes can be processed" +showReadConverter :: (Show a, Read a) => (a -> String, String -> a)+showReadConverter = (show, read)++enumConverter :: Enum a => (a -> Int, Int -> a)+enumConverter = (fromEnum, toEnum)+ firstChar :: (Char -> Char) -> String -> String firstChar f s = f (head s):tail s @@ -553,9 +567,9 @@ --mkPersist defaultCodegenConfig [groundhog| --definitions: --  - primitive: WeekDay---    representation: enum                # Its column will have integer type. The conversion will use Enum instance.+--    converter: enumConverter            # Its column will have integer type. The conversion will use Enum instance. --  - primitive: Point---    representation: showread            # Its column will have string type. The conversion will use Show/Read instances. If representation is omitted, showread will be used by default.+--    converter: showReadConverter        # Its column will have string type. The conversion will use Show/Read instances. If representation is omitted, showread will be used by default. -- |] -- @ @@ -631,3 +645,12 @@     ] --  runIO $ putStrLn $ pprint decs   return decs)++fromDataD :: InstanceDec -> (Name, [TyVarBndr], [Con])+fromDataD d = case d of+#if MIN_VERSION_template_haskell(2, 11, 0)+  (DataD _ dName typeVars _ constrs _) -> (dName, typeVars, constrs)+#else+  (DataD _ dName typeVars constrs _) -> (dName, typeVars, constrs)+#endif+  d -> error $ "Only datatypes can be processed: " ++ show d

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, RecordWildCards, DoAndIfThenElse #-}
+{-# LANGUAGE TemplateHaskell, RecordWildCards, DoAndIfThenElse, ExplicitForAll #-}
 {-# LANGUAGE CPP #-}
 
 module Database.Groundhog.TH.CodeGen
@@ -30,8 +30,8 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Control.Applicative
-import Control.Arrow (second)
-import Control.Monad (liftM, liftM2, forM, forM_, foldM, filterM, replicateM)
+import Control.Arrow (first)
+import Control.Monad (liftM, liftM2, forM, forM_, filterM, replicateM, zipWithM)
 import Data.Either (lefts, rights)
 import Data.List (findIndex, nub, partition)
 import Data.Maybe (catMaybes, mapMaybe)
@@ -54,24 +54,8 @@     funD 'persistName $ [ clause [pat] body [] ]
 
   toPersistValues' <- do
-    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
-    let body = if null fields
-        then [| return $ ($(listE lastPrims')++) |]
-        else do
-          let go (m, f) (fname, t) = isPrim t >>= \isP -> if isP
-              then return (m, [| (toPrimitivePersistValue $(varE proxy) $(varE fname):) |]:f)
-              else newName "x" >>= \x -> return (bindS (varP x) [| toPersistValues $(varE fname) |]:m, varE x:f)
-          (stmts, func) <- foldM go ([], []) fields        -- foldM puts reversed fields in normal order
-          let nonPrimFields' = foldr1 (\a b -> [|$a . $b|]) func
-          let result = if null lastPrims' then nonPrimFields' else [| $nonPrimFields' . ($(listE lastPrims')++) |]
-          doE $ stmts ++ [noBindS [| return $ $result |]]
-    anyPrim <- liftM or $ mapM (isPrim . snd) vars
-    let body' = if anyPrim then [| phantomDb >>= $(lamE [varP proxy] body) |] else body
-    funD 'toPersistValues [clause [pat] (normalB body') []]
+    (pat, body) <- mkToPersistValues (thEmbeddedConstructorName def) (thEmbeddedFields def) id
+    funD 'toPersistValues [clause [pat] (normalB body) []]
 
   fromPersistValues' <- do
     xs <- newName "xs"
@@ -99,84 +83,101 @@ 
   let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)
   let decs = [persistName', toPersistValues', fromPersistValues', dbType']
-  return $ [InstanceD context (AppT (ConT ''PersistField) embedded) decs]
+  return $ [instanceD' context (AppT (ConT ''PersistField) embedded) decs]
 
+mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)
+mkToPersistValues constrName fieldDefs processResult = do
+  patVars <- mapM (const $ newName "x") fieldDefs
+  let processField fName fDef = do
+        isP <- isPrim (thFieldType fDef)
+        let field = maybe id (\convName x -> [| fst $(varE convName) $ $x |]) (thFieldConverter fDef) (varE fName)
+        if isP
+          then return (Nothing, [| (toPrimitivePersistValue $field:) |])
+          else newName "x" >>= \x -> return (Just $ bindS (varP x) [| toPersistValues $field |], varE x)
+  (binds, funcs) <- liftM (first catMaybes . unzip) $ zipWithM processField patVars fieldDefs
+  let pat = conP constrName $ map varP patVars
+      result = [| return $ $(processResult $ if null funcs then [| id |] else foldr1 (\a b -> [|$a . $b|]) funcs) |]
+      body = if null binds then result else doE $ binds ++ [noBindS result]
+  return (pat, body)
+
 mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
 mkFromPersistValues failureName values constrName fieldDefs = do
-  proxy <- newName "p"
-  allVars <- mapM (\f -> newName "x" >>= \fname -> return (fname, thFieldType f)) fieldDefs
+  patVars <- mapM (const $ newName "x") fieldDefs
   let failure = match wildP (normalB $ varE failureName) []
-      mkArg (fname, t) = do
-        isP <- isPrim t
-        if isP
-          then [| fromPrimitivePersistValue $(varE proxy) $(varE fname) |]
-          else varE fname
-      result = foldl (\a f -> appE a $ mkArg f) (conE constrName) allVars
+      mkArg (fName, fDef) = do
+        isP <- isPrim $ thFieldType fDef
+        let x = if isP
+                  then [| fromPrimitivePersistValue $(varE fName) |]
+                  else varE fName
+        maybe x (\convName -> [| snd $(varE convName) $ $x |]) $ thFieldConverter fDef
+      result = foldl (\func f -> appE func $ mkArg f) (conE constrName) $ zip patVars fieldDefs
       goField xs vars = do
-        (fields, rest) <- spanM (liftM not . isPrim . snd) vars
+        (fields, rest) <- spanM (liftM not . isPrim . thFieldType . snd) vars
         xss <- liftM (xs:) $ mapM (const $ newName "xs") fields
         let f oldXs newXs (fname, _) = bindS (conP '(,) [varP fname, varP newXs]) [| fromPersistValues $(varE oldXs) |]
-        let stmts = zipWith3 f xss (tail xss) fields
-        expr <- goPrim (last xss) rest
-        return $ doE $ stmts ++ [noBindS expr]
+            stmts = zipWith3 f xss (tail xss) fields
+            expr = goPrim (last xss) rest
+        doE $ stmts ++ [noBindS expr]
       goPrim xs vars = do
         xs' <- newName "xs"
-        (prims, rest) <- spanM (isPrim . snd) vars
-        body' <- case rest of
-          [] -> return [| return ($result, $(varE xs')) |]
-          _  -> goField xs' rest
-        let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prims) (normalB body') []
-        return $ if null prims
+        (prims, rest) <- spanM (isPrim . thFieldType . snd) vars
+        let body' = case rest of
+              [] -> [| return ($result, $(varE xs')) |]
+              _  -> goField xs' rest
+            m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') []
+        if null prims
           then caseE (varE xs) [m]
           else caseE (varE xs) [m, failure]
-  body <- goPrim values allVars
-  anyPrim <- liftM or $ mapM (isPrim . snd) allVars
-  body' <- if anyPrim then [| phantomDb >>= $(lamE [varP proxy] body) |] else body
-  return (anyPrim, body')
+  body <- goPrim values $ zip patVars fieldDefs
+  anyPrim <- liftM or $ mapM (isPrim . thFieldType) fieldDefs
+  return (anyPrim, body)
 
 mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> Cxt -> Q [Dec]
-mkPurePersistFieldInstance dataType cName fDefs context = do
+mkPurePersistFieldInstance dataType cName fieldDefs context = do
   toPurePersistValues' <- do
-    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
-    funD 'toPurePersistValues [clause [varP proxy, pat] (normalB body) []]
+    vars <- mapM (const $ newName "x") fieldDefs
+    let pat = conP cName $ map varP vars
+        body = mkToPurePersistValues $ zip vars fieldDefs
+    funD 'toPurePersistValues [clause [pat] (normalB body) []]
 
   fromPurePersistValues' <- let
-    goField xs vars result failure proxy = do
-      (fields, rest) <- spanM (liftM not . isPrim . snd) vars
+    goField xs vars result failure = do
+      (fields, rest) <- spanM (liftM not . isPrim . thFieldType . snd) vars
       xss <- liftM (xs:) $ mapM (const $ newName "xs") fields
-      let f oldXs newXs (fname, _) = valD (conP '(,) [varP fname, varP newXs]) (normalB [| fromPurePersistValues $(varE proxy) $(varE oldXs) |]) []
+      let f oldXs newXs (fName, _) = valD (conP '(,) [varP fName, varP newXs]) (normalB [| fromPurePersistValues $(varE oldXs) |]) []
       let stmts = zipWith3 f xss (tail xss) fields
-      (isFailureUsed, expr) <- goPrim (last xss) rest result failure proxy
+      (isFailureUsed, expr) <- goPrim (last xss) rest result failure
       return (isFailureUsed, letE stmts expr)
-    goPrim xs vars result failure proxy = do
+    goPrim xs vars result failure = do
       xs' <- newName "xs"
-      (prims, rest) <- spanM (isPrim . snd) vars
+      (prims, rest) <- spanM (isPrim . thFieldType . snd) vars
       (isFailureUsed, body') <- case rest of
         [] -> return (False, [| ($result, $(varE xs')) |])
-        _  -> goField xs' rest result failure proxy
-      let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prims) (normalB body') []
+        _  -> goField xs' rest result failure
+      let m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') []
       return $ if null prims
          then (isFailureUsed, caseE (varE xs) [m])
          else (True, caseE (varE xs) [m, failure])
-    mkArg proxy (fname, t) = isPrim t >>= \isP -> (if isP then [| fromPrimitivePersistValue $(varE proxy) $(varE fname) |] else (varE fname))
+    mkArg (fName, fDef) = do
+      isP <- isPrim $ thFieldType fDef
+      let x = if isP
+                then [| fromPrimitivePersistValue $(varE fName) |]
+                else varE fName
+      maybe x (\convName -> [| snd $(varE convName) $ $x |]) $ thFieldConverter fDef
     in do
       xs <- newName "xs"
       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, thFieldType f)) fDefs
+      patVars <- mapM (const $ newName "x") fieldDefs
       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
+          result = foldl (\a f -> appE a $ mkArg f) (conE cName) $ zip patVars fieldDefs
+      (isFailureUsed, start) <- goPrim xs (zip patVars fieldDefs) result failure
       let failureFunc = funD failureName [clause [] failureBody []]
-      let locals = if isFailureUsed then [failureFunc] else []
-      funD 'fromPurePersistValues [clause [varP proxy, varP xs] (normalB start) locals]
+          locals = if isFailureUsed then [failureFunc] else []
+      funD 'fromPurePersistValues [clause [varP xs] (normalB start) locals]
 
   let decs = [toPurePersistValues', fromPurePersistValues']
-  return $ [InstanceD context (AppT (ConT ''PurePersistField) dataType) decs]
+  return $ [instanceD' context (AppT (ConT ''PurePersistField) dataType) decs]
 
 mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedPurePersistFieldInstance def = do
@@ -204,12 +205,12 @@       proxy <- newName "p"
       a <- newName "a"
       let e = [| entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a)) |]
-          body = [| DbTypePrimitive (getAutoKeyType $(varE proxy)) False Nothing (Just (Left ($e, Nothing), Nothing, Nothing)) |]
+          body = [| DbTypePrimitive (getDefaultAutoKeyType $(varE proxy)) False Nothing (Just (Left ($e, Nothing), Nothing, Nothing)) |]
       funD 'dbType [clause [varP proxy, varP a] (normalB body) []]
     
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
     let decs = [persistName', toPersistValues', fromPersistValues', dbType']
-    return [InstanceD context (AppT (ConT ''PersistField) keyType) decs]
+    return [instanceD' context (AppT (ConT ''PersistField) keyType) decs]
   _ -> return []
 
 mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
@@ -219,15 +220,14 @@     keyType <- [t| Key $(return entity) BackendSpecific |]
     let conName = mkName $ thAutoKeyConstrName autoKey
     toPrim' <- do
-      proxy <- newName "p"
       x <- newName "x"
-      let body = [| toPrimitivePersistValue $(varE proxy) $ ((fromPrimitivePersistValue :: DbDescriptor db => proxy db -> PersistValue -> AutoKeyType db) $(varE proxy)) $(varE x) |]
-      funD 'toPrimitivePersistValue [clause [varP proxy, conP conName [varP x]] (normalB body) []]
-    fromPrim' <- funD 'fromPrimitivePersistValue [clause [wildP] (normalB $ conE conName) []]
+      let body = [| $(varE x) |]
+      funD 'toPrimitivePersistValue [clause [conP conName [varP x]] (normalB body) []]
+    fromPrim' <- funD 'fromPrimitivePersistValue [clause [] (normalB $ conE conName) []]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
     let decs = [toPrim', fromPrim']
-    sequence [ return $ InstanceD context (AppT (ConT ''PrimitivePersistField) keyType) decs
-             , return $ InstanceD context (AppT (ConT ''NeverNull) keyType) []
+    sequence [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) keyType) decs
+             , return $ instanceD' context (AppT (ConT ''NeverNull) keyType) []
              , mkDefaultPurePersistFieldInstance context keyType
              , mkDefaultSinglePersistFieldInstance context keyType]
   _ -> return []
@@ -237,14 +237,14 @@   toPurePersistValues' <- funD 'toPurePersistValues [clause [] (normalB [| primToPurePersistValues |]) []]
   fromPurePersistValues' <- funD 'fromPurePersistValues [clause [] (normalB [| primFromPurePersistValues |]) []]
   let decs = [toPurePersistValues', fromPurePersistValues']
-  return $ InstanceD context (AppT (ConT ''PurePersistField) typ) decs
+  return $ instanceD' context (AppT (ConT ''PurePersistField) typ) decs
 
 mkDefaultSinglePersistFieldInstance :: Cxt -> Type -> Q Dec
 mkDefaultSinglePersistFieldInstance context typ = do
   toSinglePersistValue' <- funD 'toSinglePersistValue [clause [] (normalB [| primToSinglePersistValue |]) []]
   fromSinglePersistValue' <- funD 'fromSinglePersistValue [clause [] (normalB [| primFromSinglePersistValue |]) []]
   let decs = [toSinglePersistValue', fromSinglePersistValue']
-  return $ InstanceD context (AppT (ConT ''SinglePersistField) typ) decs
+  return $ instanceD' context (AppT (ConT ''SinglePersistField) typ) decs
 
 mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysIsUniqueInstances def = do
@@ -263,7 +263,7 @@       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)
-    return $ InstanceD context (AppT (ConT ''IsUniqueKey) uniqKeyType) [extractUnique', uniqueNum']
+    return $ instanceD' context (AppT (ConT ''IsUniqueKey) uniqKeyType) [extractUnique', uniqueNum']
 
 mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysEmbeddedInstances def = do
@@ -299,7 +299,7 @@       funD 'dbType [clause [varP proxy, varP a] (normalB body) []]
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
     let decs = [persistName', toPersistValues', fromPersistValues', dbType']
-    return $ InstanceD context (AppT (ConT ''PersistField) uniqKeyType) decs
+    return $ instanceD' context (AppT (ConT ''PersistField) uniqKeyType) decs
     
 mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
 mkUniqueKeysPrimitiveOrPurePersistFieldInstances def = do
@@ -313,14 +313,13 @@       _      -> return False
     if isUniquePrim
       then do
-        proxy <- newName "p"
         x <- newName "x"
         toPrim' <- do
-          funD 'toPrimitivePersistValue [clause [varP proxy, conP conName [varP x]] (normalB [| toPrimitivePersistValue $(varE proxy) $(varE x) |]) []]
-        fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB [| $(conE conName) (fromPrimitivePersistValue $(varE proxy) $(varE x)) |]) []]
+          funD 'toPrimitivePersistValue [clause [conP conName [varP x]] (normalB [| toPrimitivePersistValue $(varE x) |]) []]
+        fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP x] (normalB [| $(conE conName) (fromPrimitivePersistValue $(varE x)) |]) []]
         let decs = [toPrim', fromPrim']
-        sequence [ return $ InstanceD context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs
-                 , return $ InstanceD context (AppT (ConT ''NeverNull) uniqKeyType) decs
+        sequence [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs
+                 , return $ instanceD' context (AppT (ConT ''NeverNull) uniqKeyType) decs
                  , mkDefaultPurePersistFieldInstance context uniqKeyType
                  , mkDefaultSinglePersistFieldInstance context uniqKeyType]
       else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context
@@ -364,12 +363,12 @@       keyType <- [t| Key $(return entity) $u |]
       readPrec' <- funD 'R.readPrec [clause [] (normalB body) []]
       readListPrec' <- funD 'R.readListPrec [clause [] (normalB [| R.readListPrecDefault |]) []]
-      return $ InstanceD context (AppT (ConT ''Read) keyType) [readPrec', readListPrec']
+      return $ instanceD' context (AppT (ConT ''Read) keyType) [readPrec', readListPrec']
     in mapM mkRead keysInfo
 
   return $ if null keysInfo
     then []
-    else [InstanceD context (AppT (ConT ''Eq) typ) [eq'], InstanceD context (AppT (ConT ''Show) typ) [showsPrec']] ++ read'
+    else [instanceD' context (AppT (ConT ''Eq) typ) [eq'], instanceD' context (AppT (ConT ''Show) typ) [showsPrec']] ++ read'
 
 mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]
 mkEmbeddedInstance def = do
@@ -383,7 +382,7 @@   selector' <- do
     fParam <- newName "f"
     let mkField field = ForallC [] ([equalP' (VarT fParam) (thFieldType field)]) $ NormalC (mkName $ thExprName field) []
-    return $ DataInstD [] ''Selector [dataType, VarT fParam] (map mkField fDefs) []
+    return $ dataInstD' [] ''Selector [dataType, VarT fParam] (map mkField fDefs) []
 
   selectorNum' <- do
     let mkClause fNum field = clause [conP (mkName $ thExprName field) []] (normalB $ lift fNum) []
@@ -391,7 +390,7 @@     funD 'selectorNum clauses
 
   let decs = [selector', selectorNum']
-  return $ [InstanceD context (AppT (ConT ''Embedded) dataType) decs]
+  return $ [instanceD' context (AppT (ConT ''Embedded) dataType) decs]
 
 mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
 mkEntityPhantomConstructors def = do
@@ -401,7 +400,7 @@     let name = mkName $ thPhantomConstrName c
     phantom <- [t| ConstructorMarker $(return entity) |]
     let constr = ForallC (thTypeParams def) [equalP' (VarT v) phantom] $ NormalC name []
-    return $ DataD [] name [PlainTV v] [constr] []
+    return $ dataD' [] name [PlainTV v] [constr] []
   
 mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
 mkEntityPhantomConstructorInstances def = sequence $ zipWith f [0..] $ thConstructors def where
@@ -420,7 +419,7 @@         let name = mkName $ thUniqueKeyPhantomName u
         phantom <- [t| UniqueMarker $(return entity) |]
         let constr = ForallC (thTypeParams def) [equalP' (VarT v) phantom] $ NormalC name []
-        return [DataD [] name [PlainTV v] [constr] []]
+        return [dataD' [] name [PlainTV v] [constr] []]
       else return []
     
 mkPersistEntityInstance :: THEntityDef -> Q [Dec]
@@ -433,15 +432,15 @@       Nothing -> return []
       Just k -> do
         keyDescr <- [t| BackendSpecific |]
-        return [ForallC [] [equalP' (VarT uParam) keyDescr] $ NormalC (mkName $ thAutoKeyConstrName k) [(NotStrict, ConT ''PersistValue)]]
+        return [ForallC [] [equalP' (VarT uParam) keyDescr] $ NormalC (mkName $ thAutoKeyConstrName k) [(notStrict', ConT ''PersistValue)]]
     uniques <- forM (thUniqueKeys def) $ \unique -> do
       uniqType <- [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName unique) |]
       let cDef = head $ thConstructors def
           uniqFieldNames = lefts $ thUniqueFields $ findOne "unique" thUniqueName (thUniqueKeyName unique) $ thConstrUniques cDef
           uniqFields = concat $ flip map uniqFieldNames $ \name -> (filter ((== name) . thFieldName) $ thConstrFields cDef)
-          uniqFields' = map (\f -> (NotStrict, thFieldType f)) uniqFields
+          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) []
+    return $ dataInstD' [] ''Key [entity, VarT uParam] (autoKey ++ uniques) []
 
   autoKey' <- do
     autoType <- case thAutoKey def of
@@ -469,7 +468,7 @@     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 []
+    return $ dataInstD' [] ''Field [entity, VarT cParam, VarT fParam] constrs []
     
   entityDef' <- do
     v <- newName "v"
@@ -504,27 +503,12 @@     funD 'entityDef $ [ clause [varP proxy, entityPat] body [] ]
 
   toEntityPersistValues' <- liftM (FunD 'toEntityPersistValues) $ forM (zip [0 :: Int ..] $ thConstructors def) $ \(cNum, c) -> do
-    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
-    let lastPrims' = map (\(x, _) -> [| toPrimitivePersistValue $(varE proxy) $(varE x) |]) $ reverse $ lastPrims
-    let body = if null fields
-        then [| return $ ($(listE $ [|toPrimitivePersistValue $(varE proxy) ($(lift cNum) :: Int) |]:lastPrims')++) |]
-        else do
-          let go (m, f) (fname, t) = isPrim t >>= \isP -> if isP
-              then return (m, [| (toPrimitivePersistValue $(varE proxy) $(varE fname):) |]:f)
-              else newName "x" >>= \x -> return (bindS (varP x) [| toPersistValues $(varE fname) |]:m, varE x:f)
-          (stmts, func) <- foldM go ([], []) fields        -- foldM puts reversed fields in normal order
-          let nonPrimFields' = foldr1 (\a b -> [|$a . $b|]) func
-          let result = if null lastPrims' then nonPrimFields' else [| $nonPrimFields' . ($(listE lastPrims')++) |]
-          doE $ stmts ++ [noBindS [| return $ (toPrimitivePersistValue $(varE proxy) ($(lift cNum) :: Int):) . $result |]]
-    let body' = [| phantomDb >>= $(lamE [varP proxy] body) |]
-    clause [pat] (normalB body') []
+    (pat, body) <- mkToPersistValues (thConstrName c) (thConstrFields c) (\result -> [| (toPrimitivePersistValue ($(lift cNum) :: Int) :) . $result |])
+    clause [pat] (normalB body) []
 
   fromEntityPersistValues' <- do
       xs <- newName "xs"
-      let failureBody = normalB [| (\a -> phantomDb >>= \proxy -> fail (failMessageNamed (entityName $ entityDef proxy a) $(varE xs)) >> return (a, [])) undefined |]
+      let failureBody = normalB [| fail (failMessageNamed $(stringE $ show $ thDataName def) $(varE xs)) |]
       failureName <- newName "failure"
       let failure = match wildP (normalB $ varE failureName) []
       matches <- forM (zip [0..] (thConstructors def)) $ \(cNum, c) -> do
@@ -539,22 +523,21 @@   getUniques' <- let
     hasConstraints = not . null . thConstrUniques
     clauses = zipWith mkClause [0::Int ..] (thConstructors def)
-    mkClause cNum cdef | not (hasConstraints cdef) = clause [wildP, conP (thConstrName cdef) pats] (normalB [| (cNum, []) |]) [] where
+    mkClause cNum cdef | not (hasConstraints cdef) = clause [conP (thConstrName cdef) pats] (normalB [| (cNum, []) |]) [] where
       pats = map (const wildP) $ thConstrFields cdef
     mkClause cNum cdef = do
       let allConstrainedFields = lefts $ concatMap thUniqueFields $ thConstrUniques cdef
       vars <- mapM (\f -> newName "x" >>= \x -> return $ if thFieldName f `elem` allConstrainedFields then Just (x, f) else Nothing) $ thConstrFields cdef
-      proxy <- newName "p"
       let pat = conP (thConstrName cdef) $ map (maybe wildP (varP . fst)) vars
           body = normalB $ [| (cNum, $(listE $ mapMaybe mkUnique $ thConstrUniques cdef)) |]
           mkUnique (THUniqueDef uName _ fnames) = if null $ rights fnames
             then let
               -- find corresponding field from vars
               uFields = map (\f -> findOne "field" (thFieldName . snd) f $ catMaybes vars) $ lefts fnames
-              result = mkToPurePersistValues proxy $ map (second thFieldType) uFields
+              result = mkToPurePersistValues uFields
               in Just [| (uName, $result) |]
             else Nothing
-      clause [varP proxy, pat] body []
+      clause [pat] body []
     in funD 'getUniques clauses
 
   entityFieldChain' <- let
@@ -572,22 +555,19 @@ 
   let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
   let decs = [key', autoKey', defaultKey', isSumType', fields', entityDef', toEntityPersistValues', fromEntityPersistValues', getUniques', entityFieldChain']
-  return $ [InstanceD context (AppT (ConT ''PersistEntity) entity) decs]
+  return $ [instanceD' context (AppT (ConT ''PersistEntity) entity) decs]
 
-mkToPurePersistValues :: Name -> [(Name, Type)] -> Q Exp
-mkToPurePersistValues proxy vars = do
-  (lastPrims, fields) <- spanM (isPrim . snd) $ reverse vars
-  let lastPrims' = map (\(x, _) -> [| toPrimitivePersistValue $(varE proxy) $(varE x) |]) $ reverse $ lastPrims
-  if null fields
-    then [| ($(listE lastPrims')++) |]
-    else do
-      let go (m, f) (fname, t) = isPrim t >>= \isP -> if isP
-          then return (m, [| (toPrimitivePersistValue $(varE proxy) $(varE fname):) |]:f)
-          else newName "x" >>= \x -> return (valD (varP x) (normalB [| toPurePersistValues $(varE proxy) $(varE fname) |]) []:m, varE x:f)
-      (stmts, func) <- foldM go ([], []) fields        -- foldM puts reversed fields in normal order
-      let nonPrimFields' = foldr1 (\a b -> [|$a . $b|]) func
-      let result = if null lastPrims' then nonPrimFields' else [| $nonPrimFields' . ($(listE lastPrims')++) |]
-      letE stmts result
+mkToPurePersistValues :: [(Name, THFieldDef)] -> Q Exp
+mkToPurePersistValues vars = do
+  let processField (fName, fDef) = do
+        isP <- isPrim (thFieldType fDef)
+        let field = maybe id (\convName x -> [| fst $(varE convName) $ $x |]) (thFieldConverter fDef) (varE fName)
+        if isP
+          then return (Nothing, [| (toPrimitivePersistValue $field:) |])
+          else newName "x" >>= \x -> return (Just $ valD (varP x) (normalB [| toPurePersistValues $(varE fName) |]) [], varE x)
+  (lets, funcs) <- liftM (first catMaybes . unzip) $ mapM processField vars
+  let result = if null funcs then [| id |] else foldr1 (\a b -> [|$a . $b|]) funcs
+  if null lets then result else letE lets result
 
 mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
 mkEntityPersistFieldInstance def = case getDefaultKey def of
@@ -633,7 +613,7 @@ 
     let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
     let decs = [persistName', toPersistValues', fromPersistValues', dbType']
-    return $ [InstanceD context (AppT (ConT ''PersistField) entity) decs]
+    return $ [instanceD' context (AppT (ConT ''PersistField) entity) decs]
   Nothing -> return []
 
 mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]
@@ -651,7 +631,7 @@     toSinglePersistValue' <- funD 'toSinglePersistValue $ [ clause [] (normalB to) [] ]
     fromSinglePersistValue' <- funD 'fromSinglePersistValue $ [ clause [] (normalB from) []]
     let decs = [toSinglePersistValue', fromSinglePersistValue']
-    return [InstanceD context (AppT (ConT ''SinglePersistField) entity) decs]
+    return [instanceD' context (AppT (ConT ''SinglePersistField) entity) decs]
   _ -> return []
 
 mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]
@@ -661,7 +641,7 @@       context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
   isOne <- isDefaultKeyOneColumn def
   return $ if isOne
-    then [InstanceD context (AppT (ConT ''NeverNull) entity) []]
+    then [instanceD' context (AppT (ConT ''NeverNull) entity) []]
     else []
 
 mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
@@ -673,37 +653,27 @@   fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []]
   toPersistValues' <- funD 'toPersistValues [clause [] (normalB [| primToPersistValue |]) []]
   dbType' <- do
-    let typ = if thPrimitiveStringEnumRepresentation def
-          then [| DbTypePrimitive DbString False Nothing Nothing |]
-          else [| DbTypePrimitive DbInt32  False Nothing Nothing |]
-    funD 'dbType $ [ clause [wildP, wildP] (normalB typ) [] ]
+    proxy <- newName "p"
+    x <- newName "x"
+    let body = [| dbType $(varE proxy) $ fst $(varE $ thPrimitiveConverter def) $ $(varE x) |]
+    funD 'dbType $ [ clause [varP proxy, varP x] (normalB body) [] ]
   let decs = [persistName', toPersistValues', fromPersistValues', dbType']
-  return [ InstanceD [] (AppT (ConT ''PersistField) primitive) decs
-         , InstanceD [] (AppT (ConT ''NeverNull) primitive) []
+  return [ instanceD' [] (AppT (ConT ''PersistField) primitive) decs
+         , instanceD' [] (AppT (ConT ''NeverNull) primitive) []
          ]
 
 mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]
 mkPrimitivePrimitivePersistFieldInstance def = do
   let primitive = ConT (thPrimitiveName def)
   toPrim' <- do
-    proxy <- newName "p"
-    x <- newName "x"
-    let value = if thPrimitiveStringEnumRepresentation def
-          then [| show $(varE x) |]
-          else [| fromEnum $(varE x) |]
-        body = [| toPrimitivePersistValue $(varE proxy) $value |]
-    funD 'toPrimitivePersistValue [clause [varP proxy, varP x] (normalB body) []]
+    let body = [| toPrimitivePersistValue . fst $(varE $ thPrimitiveConverter def) |]
+    funD 'toPrimitivePersistValue [clause [] (normalB body) []]
   fromPrim' <- do
-    proxy <- newName "p"
-    x <- newName "x"
-    let value = [| fromPrimitivePersistValue $(varE proxy) $(varE x) |]
-        body = if thPrimitiveStringEnumRepresentation def
-          then [| read $value |]
-          else [| toEnum $value |]
-    funD 'fromPrimitivePersistValue [clause [varP proxy, varP x] (normalB body) []]
+    let body = [| snd $(varE $ thPrimitiveConverter def) . fromPrimitivePersistValue |]
+    funD 'fromPrimitivePersistValue [clause [] (normalB body) []]
   let context = []
   let decs = [toPrim', fromPrim']
-  sequence $ [return $ InstanceD context (AppT (ConT ''PrimitivePersistField) primitive) decs
+  sequence $ [return $ instanceD' context (AppT (ConT ''PrimitivePersistField) primitive) decs
            , mkDefaultPurePersistFieldInstance context primitive
            , mkDefaultSinglePersistFieldInstance context primitive]
 
@@ -712,7 +682,7 @@   let (normal, polymorhpic) = partition (null . thTypeParams) defs
   forM_ polymorhpic $ \def -> reportWarning $ "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 |]
+  sig <- sigD (mkName name) [t| forall m . PersistBackend m => Migration m |]
   func <- funD (mkName name) [clause [] (normalB body) []]
   return [sig, func]
 
@@ -809,13 +779,14 @@       else return ([], x:xs)
 
 mkType :: THFieldDef -> Name -> ExpQ -> ExpQ
-mkType THFieldDef{..} proxy nvar = t2 where
-  psField = PSFieldDef thFieldName (Just thDbFieldName) thDbTypeName (Just thExprName) thEmbeddedDef thDefaultValue thReferenceParent
-  t1 = [| dbType $(varE proxy) $nvar |]
+mkType THFieldDef{..} proxy nvar = t3 where
+  psField = PSFieldDef thFieldName (Just thDbFieldName) thDbTypeName (Just thExprName) thEmbeddedDef thDefaultValue thReferenceParent (fmap show thFieldConverter)
+  t1 = maybe id (\convName x -> [| fst $(varE convName) $ $x |]) thFieldConverter nvar
+  t2 = [| dbType $(varE proxy) $t1 |]
   -- if there are any type settings, apply them in runtime
-  t2 = case (thDbTypeName, thEmbeddedDef, thDefaultValue, thReferenceParent) of
-    (Nothing, Nothing, Nothing, Nothing) -> t1
-    _ -> [| applyDbTypeSettings $(lift psField) $t1 |]
+  t3 = case (thDbTypeName, thEmbeddedDef, thDefaultValue, thReferenceParent) of
+    (Nothing, Nothing, Nothing, Nothing) -> t2
+    _ -> [| applyDbTypeSettings $(lift psField) $t2 |]
 
 mkTySynInstD :: Name -> [Type] -> Type -> Dec
 mkTySynInstD name ts t =
@@ -839,4 +810,36 @@   foldl AppT EqualityT [t1, t2]
 #else
   EqualP t1 t2
+#endif
+
+instanceD' :: Cxt -> Type -> [Dec] -> InstanceDec
+instanceD' =
+#if MIN_VERSION_template_haskell(2, 11, 0)
+  InstanceD Nothing
+#else
+  InstanceD
+#endif
+
+dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec
+dataInstD' cxt name types constrs derives =
+#if MIN_VERSION_template_haskell(2, 11, 0)
+  DataInstD cxt name types Nothing constrs (map ConT derives)
+#else
+  DataInstD cxt name types constrs derives
+#endif
+
+dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec
+dataD' cxt name types constrs derives =
+#if MIN_VERSION_template_haskell(2, 11, 0)
+  DataD cxt name types Nothing constrs (map ConT derives)
+#else
+  DataD cxt name types constrs derives
+#endif
+
+#if MIN_VERSION_template_haskell(2, 11, 0)
+notStrict' :: Bang
+notStrict' = Bang NoSourceUnpackedness NoSourceStrictness
+#else
+notStrict' :: Strict
+notStrict' = NotStrict
 #endif

@@ -26,7 +26,7 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Control.Applicative
-import Control.Monad (forM, mzero)
+import Control.Monad (forM, mzero, when)
 import Data.Aeson
 import Data.Aeson.Types (Pair)
 import qualified Data.Foldable as Fold
@@ -64,7 +64,7 @@ data THPrimitiveDef = THPrimitiveDef {
     thPrimitiveName :: Name
   , thPrimitiveDbName :: String -- ^ It is used only to set polymorphic part of name of its container
-  , thPrimitiveStringEnumRepresentation :: Bool -- ^ Store in database as string using Show/Read instances (True) or as integer using Enum instance (False).
+  , thPrimitiveConverter :: Name -- ^ Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`
 } deriving (Eq, Show)
 
 data THConstructorDef = THConstructorDef {
@@ -77,14 +77,15 @@ } deriving (Eq, Show)
 
 data THFieldDef = THFieldDef {
-    thFieldName :: String -- bar
-  , thDbFieldName :: String -- SQLbar
-  , thDbTypeName :: Maybe String -- inet, NUMERIC(5, 2), VARCHAR(50)
-  , thExprName :: String -- BarField
+    thFieldName :: String -- ^ name in the record, bar
+  , thDbFieldName :: String -- ^ column name, SQLbar
+  , thDbTypeName :: Maybe String -- ^ column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.
+  , thExprName :: String -- ^ name of constructor in the Field GADT, BarField
   , thFieldType :: Type
   , thEmbeddedDef :: Maybe [PSFieldDef String]
-  , thDefaultValue :: Maybe String
+  , thDefaultValue :: Maybe String -- ^ default value in the database
   , thReferenceParent :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType)
+  , thFieldConverter :: Maybe Name -- ^ name of a pair of functions
 } deriving (Eq, Show)
 
 data THUniqueDef = THUniqueDef {
@@ -122,7 +123,7 @@ data PSPrimitiveDef = PSPrimitiveDef {
     psPrimitiveName :: String
   , psPrimitiveDbName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container
-  , psPrimitiveStringEnumRepresentation :: Maybe Bool -- ^ Store in database as string using Show/Read instances (True) or as integer using Enum instance (False).
+  , psPrimitiveConverter :: String -- ^ Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`
 } deriving (Eq, Show)
 
 data PSConstructorDef = PSConstructorDef {
@@ -156,7 +157,7 @@ } deriving (Eq, Show)
 
 instance Lift PSPrimitiveDef where
-  lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveStringEnumRepresentation) |]
+  lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveConverter) |]
 
 instance Lift PersistDefinitions where
   lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift psEntities) $(lift psEmbeddeds) $(lift psPrimitives) |]
@@ -186,7 +187,7 @@   lift SetDefault = [| SetDefault |]
 
 instance Lift (PSFieldDef String) where
-  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) $(lift psDefaultValue) $(lift psReferenceParent) |]
+  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) $(lift psDefaultValue) $(lift psReferenceParent) $(lift psFieldConverter) |]
 
 instance Lift PSUniqueKeyDef where
   lift (PSUniqueKeyDef {..}) = [| PSUniqueKeyDef $(lift psUniqueKeyName) $(lift psUniqueKeyPhantomName) $(lift psUniqueKeyConstrName) $(lift psUniqueKeyDbName) $(lift psUniqueKeyFields) $(lift psUniqueKeyMakeEmbedded) $(lift psUniqueKeyIsDef) |]
@@ -230,13 +231,8 @@ 
 instance FromJSON PSPrimitiveDef where
   parseJSON = withObject "primitive" $ \v -> do
-    x <- v .:? "representation"
-    let representation = case x of
-          Nothing -> pure True
-          Just "showread" -> pure True
-          Just "enum" -> pure False
-          Just r -> fail $ "parseJSON: representation expected [\"showread\",\"enum\"], but got " ++ r
-    PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> pure representation
+    when (H.member "representation" v) $ fail $ "parseJSON: field 'representation' is deprecated. Use 'converter' instead: " ++ show v
+    PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> v .: "converter"
 
 instance FromJSON PSConstructorDef where
   parseJSON = withObject "constructor" $ \v ->
@@ -268,7 +264,7 @@ 
 instance FromJSON (PSFieldDef String) where
   parseJSON = withObject "field" $ \v ->
-    PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings v where
+    PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings v <*> v .:? "converter" where
     mkRefSettings v = do
       ref <- v .:? "reference"
       (parent, onDel, onUpd) <- case ref of

@@ -1,3 +1,8 @@+0.8+* Support for GHC 8+* Generation of instances for newtype+* Converter functions for primitive datatypes+ 0.7.0.1 * Compatibility with template-haskell-2.10 

@@ -1,5 +1,5 @@ name:            groundhog-th-version:         0.7.0.1+version:         0.8 license:         BSD3 license-file:    LICENSE author:          Boris Lykah <lykahb@gmail.com>@@ -17,7 +17,7 @@ library     build-depends:   base                     >= 4         && < 5                    , bytestring               >= 0.9-                   , groundhog                >= 0.7       && < 0.8+                   , groundhog                >= 0.8       && < 0.9                    , template-haskell                    , time                     >= 1.1.4                    , containers               >= 0.2