groundhog-th (empty) → 0.1.0

raw patch · 6 files changed

+1455/−0 lines, 6 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, groundhog, template-haskell, time, yaml

Files

Database/Groundhog/TH.hs +500/−0
Database/Groundhog/TH/CodeGen.hs +695/−0
Database/Groundhog/TH/Settings.hs +219/−0
LICENSE +10/−0
Setup.hs +2/−0
groundhog-th.cabal +29/−0

+ Database/Groundhog/TH.hs view

@@ -0,0 +1,500 @@+{-# LANGUAGE TemplateHaskell, RecordWildCards #-}++-- | This module provides functions to generate the auxiliary structures for the user data type+module Database.Groundhog.TH+  ( +  -- * Settings format+  -- $settingsDoc+    mkPersist+  , groundhog+  , groundhogFile+  -- * Settings for code generation+  , CodegenConfig(..)+  , defaultCodegenConfig+  -- $namingStylesDoc+  , NamingStyle(..)+  , suffixNamingStyle+  , persistentNamingStyle+  , conciseNamingStyle+  ) where++import Database.Groundhog.Core (delim)+import Database.Groundhog.Generic+import Database.Groundhog.TH.CodeGen+import Database.Groundhog.TH.Settings+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (StrictType, VarStrictType, Lift(..))+import Language.Haskell.TH.Quote+import Control.Monad (forM, forM_, when, unless, liftM2)+import Data.ByteString.Char8 (pack)+import Data.Char (toUpper, toLower, isSpace)+import Data.Either (lefts)+import Data.List (nub, (\\))+import Data.Maybe (fromMaybe, isNothing)+import Data.Yaml (decodeEither)++data CodegenConfig = CodegenConfig {+    -- | Naming style that is applied for all definitions+    namingStyle :: NamingStyle+    -- | Codegenerator will create a function with this name that will run 'migrate' for each non-polymorphic entity in definition+  , migrationFunction :: Maybe String+}++defaultCodegenConfig :: CodegenConfig+defaultCodegenConfig = CodegenConfig suffixNamingStyle Nothing++-- $namingStylesDoc+-- When describing a datatype you can omit the most of the declarations. +-- In this case the omitted parts of description will be automatically generated using the default names created by naming style.+-- Any default name can be overridden by setting its value explicitly.++-- | Defines how the names are created. The mk* functions correspond to the set* functions.+-- Functions mkNormal* define names of non-record constructor Field+data NamingStyle = NamingStyle {+  -- | Create name of the table for the datatype. Parameters: data name.+    mkDbEntityName :: String -> String+  -- | Create name of the backend-specific key constructor for the datatype. Parameters: data name.+  , mkEntityKeyName :: String -> String+  -- | Create name for phantom constructor used to parametrise 'Field'. Parameters: data name, constructor name, constructor position.+  , mkPhantomName :: String -> String -> Int -> String+  -- | Create name for phantom unique key used to parametrise 'Key'. Parameters: data name, constructor name, unique constraint name.+  , mkUniqueKeyPhantomName :: String -> String -> String -> String+  -- | Create name of constructor for the unique key. Parameters: data name, constructor name, unique constraint name.+  , mkUniqueKeyConstrName :: String -> String -> String -> String+  -- | Create name used by 'persistName' for the unique key. Parameters: data name, constructor name, unique constraint name.+  , mkUniqueKeyDbName :: String -> String -> String -> String+  -- | Create name of the constructor specific table. Parameters: data name, constructor name, constructor position.+  , mkDbConstrName :: String -> String -> Int -> String+  -- | Create name of the db field for autokey. Parameters: data name, constructor name, constructor position.+  , mkDbConstrAutoKeyName :: String -> String -> Int -> String+  -- | Create name of the field column in a database. Parameters: data name, constructor name, constructor position, field record name, field position.+  , mkDbFieldName :: String -> String -> Int -> String -> Int -> String+  -- | Create name of field constructor used in expressions. Parameters: data name, constructor name, constructor position, field record name, field position.+  , mkExprFieldName :: String -> String -> Int -> String -> Int -> String+  -- | Create name of selector (see 'Embedded') constructor used in expressions. Parameters: data name, constructor name, field record name, field position.+  , mkExprSelectorName :: String -> String -> String -> Int -> String+  -- | Create field name used to refer to the it in settings for non-record constructors. Parameters: data name, constructor name, constructor position, field position.+  , mkNormalFieldName :: String -> String -> Int -> Int -> String+  -- | Create name of the field column in a database. Parameters: data name, constructor name, constructor position, field position.+  , mkNormalDbFieldName :: String -> String -> Int -> Int -> String+  -- | Create name of field constructor used in expressions. Parameters: data name, constructor name, constructor position, field position.+  , mkNormalExprFieldName :: String -> String -> Int -> Int -> String+  -- | Create name of selector (see 'Embedded') constructor used in expressions. Parameters: data name, constructor name, field position.+  , mkNormalExprSelectorName :: String -> String -> Int -> String+}++-- | Default style. Adds \"Field\" to each record field name.+--+-- Example:+--+-- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}+-- > -- Generated code+-- > data NormalConstructor+-- > data RecordConstructor+-- > instance PersistEntity where+-- >   data Field (SomeData a) where+-- >     Normal0Field :: Field NormalConstructor Int+-- >     BarField :: Field RecordConstructor (Maybe String)+-- >     AscField :: Field RecordConstructor a+-- > ...+suffixNamingStyle :: NamingStyle+suffixNamingStyle = NamingStyle {+    mkDbEntityName = \dName -> dName+  , mkEntityKeyName = \dName -> dName ++ "Key"+  , mkPhantomName = \_ cName _ -> cName ++ "Constructor"+  , mkUniqueKeyPhantomName = \_ _ uName -> firstLetter toUpper uName+  , mkUniqueKeyConstrName = \_ _ uName -> firstLetter toUpper uName ++ "Key"+  , mkUniqueKeyDbName = \_ _ uName -> "Key" ++ [delim] ++ firstLetter toUpper uName+  , mkDbConstrName = \_ cName _ -> cName+  , mkDbConstrAutoKeyName = \_ _ _ -> "id"+  , mkDbFieldName = \_ _ _ fName _ -> fName+  , mkExprFieldName = \_ _ _ fName _ -> firstLetter toUpper fName ++ "Field"+  , mkExprSelectorName = \_ _ fName _ -> firstLetter toUpper fName ++ "Selector"+  , mkNormalFieldName = \_ cName _ fNum -> firstLetter toLower cName ++ show fNum+  , mkNormalDbFieldName = \_ cName _ fNum -> firstLetter toLower cName ++ show fNum+  , mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum ++ "Field"+  , mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum ++ "Selector"+}++-- | Creates field names in Persistent fashion prepending constructor names to the fields.+--+-- Example:+--+-- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}+-- > -- Generated code+-- > data NormalConstructor+-- > data RecordConstructor+-- > instance PersistEntity where+-- >   data Field (SomeData a) where+-- >     Normal0 :: Field NormalConstructor Int+-- >     RecordBar :: Field RecordConstructor (Maybe String)+-- >     RecordAsc :: Field RecordConstructor a+-- > ...+persistentNamingStyle :: NamingStyle+persistentNamingStyle = suffixNamingStyle {+    mkExprFieldName = \_ cName _ fName _ -> cName ++ firstLetter toUpper fName+  , mkExprSelectorName = \_ cName fName _ -> cName ++ firstLetter toUpper fName+  , mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum+  , mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum+}++-- | Creates the shortest field names. It is more likely to lead in name conflicts than other naming styles.+--+-- Example:+--+-- > data SomeData a = Normal Int | Record { bar :: Maybe String, asc :: a}+-- > -- Generated code+-- > data NormalConstructor+-- > data RecordConstructor+-- > instance PersistEntity where+-- >   data Field (SomeData a) where+-- >     Normal0 :: Field NormalConstructor Int+-- >     Bar :: Field RecordConstructor (Maybe String)+-- >     Asc :: Field RecordConstructor a+-- > ...+conciseNamingStyle :: NamingStyle+conciseNamingStyle = suffixNamingStyle {+    mkExprFieldName = \_ _ _ fName _ -> firstLetter toUpper fName+  , mkExprSelectorName = \_ _ fName _ -> firstLetter toUpper fName+  , mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum+  , mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum+}++-- | Creates the auxiliary structures. +-- Particularly, it creates GADT 'Field' data instance for referring to the fields in expressions and phantom types for data constructors.+-- The default names of auxiliary datatypes and names used in database are generated using the naming style and can be changed via configuration.+-- The datatypes and their generation options are defined via YAML configuration parsed by quasiquoter 'groundhog'. +mkPersist :: CodegenConfig -> PersistDefinitions -> Q [Dec]+mkPersist CodegenConfig{..} (PersistDefinitions defs) = do+  let duplicates = notUniqueBy id $ map (either psDataName psEmbeddedName) defs+  unless (null duplicates) $ fail $ "All definitions must be unique. Found duplicates: " ++ show duplicates+  defs' <- forM defs $ \def -> do+    let name = mkName $ either psDataName psEmbeddedName def+    info <- reify name+    return $ case info of+      TyConI x -> case x of+        d@DataD{}  -> case def of+          Left  ent -> either error Left $ validateEntity $ applyEntitySettings namingStyle ent $ mkTHEntityDefWith namingStyle d+          Right emb -> either error Right $ validateEmbedded $ applyEmbeddedSettings emb $ mkTHEmbeddedDefWith namingStyle d+        NewtypeD{} -> error "Newtypes are not supported"+        _ -> error $ "Unknown declaration type: " ++ show name ++ " " ++ show x+      _        -> error $ "Only datatypes can be processed: " ++ show name+  decs <- mapM (either mkEntityDecs mkEmbeddedDecs) defs'+  migrateFunc <- maybe (return []) (\name -> mkMigrateFunction name (lefts defs')) migrationFunction+  return $ migrateFunc ++ concat decs++applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef+applyEntitySettings style settings def@(THEntityDef{..}) =+  def { dbEntityName = fromMaybe dbEntityName $ psDbEntityName settings+      , thAutoKey = thAutoKey'+      , thUniqueKeys = maybe thUniqueKeys (map mkUniqueKey') $ psUniqueKeys settings+      , thConstructors = thConstructors'+      } where+  thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) $ psAutoKey settings++  thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors settings where+    thConstructors'' = maybe id (\_ -> zipWith putAutoKey [0..]) thAutoKey' thConstructors+    putAutoKey cNum cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = Just $ mkDbConstrAutoKeyName style (nameBase dataName) (nameBase thConstrName) cNum}++  mkUniqueKey' = mkUniqueKey style (nameBase dataName) (head thConstructors')+  f = foldr $ replaceOne "constructor" psConstrName (nameBase . thConstrName) applyConstructorSettings++mkUniqueKey :: NamingStyle -> String -> THConstructorDef -> PSUniqueKeyDef -> THUniqueKeyDef+mkUniqueKey style@NamingStyle{..} dName cDef@THConstructorDef{..} PSUniqueKeyDef{..} = key where+  key = THUniqueKeyDef {+    thUniqueKeyName = psUniqueKeyName+  , thUniqueKeyPhantomName = fromMaybe (mkUniqueKeyPhantomName dName (nameBase thConstrName) psUniqueKeyName) psUniqueKeyPhantomName+  , thUniqueKeyConstrName = fromMaybe (mkUniqueKeyConstrName dName (nameBase thConstrName) psUniqueKeyName) psUniqueKeyConstrName+  , thUniqueKeyDbName = fromMaybe (mkUniqueKeyDbName dName (nameBase thConstrName) psUniqueKeyName) psUniqueKeyDbName+  , thUniqueKeyFields = maybe uniqueFields (f uniqueFields) psUniqueKeyFields+  , thUniqueKeyMakeEmbedded = fromMaybe False psUniqueKeyMakeEmbedded+  , thUniqueKeyIsDef = fromMaybe False psUniqueKeyIsDef+  }+  f = foldr $ replaceOne "unique field" psFieldName fieldName 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+      }++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+      } where+  f = foldr $ replaceOne "field" psFieldName fieldName applyFieldSettings+  +applyFieldSettings :: PSFieldDef -> THFieldDef -> THFieldDef+applyFieldSettings settings def@(THFieldDef{..}) =+  def { dbFieldName = fromMaybe dbFieldName $ psDbFieldName settings+      , exprName = fromMaybe exprName $ psExprName settings+      , embeddedDef = psEmbeddedDef settings+      }++applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef+applyEmbeddedSettings settings def@(THEmbeddedDef{..}) =+  def { dbEmbeddedName = fromMaybe dbEmbeddedName $ psDbEmbeddedName settings+      , embeddedFields = maybe embeddedFields (f embeddedFields) $ psEmbeddedFields settings+      } where+  f = foldr $ replaceOne "field" psFieldName fieldName 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}++notUniqueBy :: Eq b => (a -> b) -> [a] -> [b]+notUniqueBy f xs = let xs' = map f xs in nub $ xs' \\ nub xs'++assertUnique :: (Monad m, Eq b, Show b) => (a -> b) -> [a] -> String -> m ()+assertUnique f xs what = case notUniqueBy f xs of+  [] -> return ()+  ys -> fail $ "All " ++ what ++ " must be unique: " ++ show ys++-- we need to validate datatype names because TH just creates unusable fields with spaces+assertSpaceFree :: Monad m => String -> String -> m ()+assertSpaceFree s what = when (any isSpace s) $ fail $ "Spaces in " ++ what ++ " are not allowed: " ++ show s++validateEntity :: THEntityDef -> Either String THEntityDef+validateEntity def = do+  let constrs = thConstructors def+  assertUnique thPhantomConstrName constrs "constructor phantom name"+  assertUnique dbConstrName 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+      [] -> 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)+      +  -- 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)+    else -- check that all unique keys reference existing uniques+         let uniqueNames = map psUniqueName $ 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)+  -- 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)+  -- 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)+  return def++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"+  return def++mkTHEntityDefWith :: NamingStyle -> Dec -> THEntityDef+mkTHEntityDefWith NamingStyle{..} (DataD _ dName typeVars cons _) =+  THEntityDef dName (mkDbEntityName dName') (Just $ THAutoKeyDef (mkEntityKeyName dName') True) [] typeVars constrs where+  constrs = zipWith mkConstr [0..] cons+  dName' = nameBase dName++  mkConstr cNum c = case c of+    NormalC name params -> mkConstr' name $ zipWith (mkField (nameBase name)) params [0..]+    RecC name params -> mkConstr' name $ zipWith (mkVarField (nameBase name)) params [0..]+    InfixC{} -> error $ "Types with infix constructors are not supported" ++ show dName+    ForallC{} -> error $ "Types with existential quantification are not supported" ++ show dName+   where+    mkConstr' name params = THConstructorDef name (apply mkPhantomName) (apply mkDbConstrName) Nothing params [] where+      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+      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+      apply f = f dName' cName cNum fName' fNum+      fName' = nameBase fName+mkTHEntityDefWith _ _ = error "Only datatypes can be processed"++mkTHEmbeddedDefWith :: NamingStyle -> Dec -> THEmbeddedDef+mkTHEmbeddedDefWith (NamingStyle{..}) (DataD _ dName typeVars cons _) =+  THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields where+  dName' = nameBase dName+  +  (cName, fields) = case cons of+    [cons'] -> case cons' of+      NormalC name params -> (name, zipWith (mkField (nameBase name)) params [0..])+      RecC name params -> (name, zipWith (mkVarField (nameBase name)) params [0..])+      InfixC{} -> error $ "Types with infix constructors are not supported" ++ show dName+      ForallC{} -> error $ "Types with existential quantification are not supported" ++ show dName+    _ -> 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+    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+    apply f = f dName' cName' 0 fName' fNum+    fName' = nameBase fName+mkTHEmbeddedDefWith _ _ = error "Only datatypes can be processed"++firstLetter :: (Char -> Char) -> String -> String+firstLetter f s = f (head s):tail s++-- $settingsDoc+-- Groundhog needs to analyze the datatypes and create the auxiliary definitions before it can work with them.+-- We use YAML-based settings to list the datatypes and adjust the result of their introspection.+-- +-- A datatype can be treated as entity or embedded. An entity is stored in its own table, can be referenced in fields of other data, etc. It is a first-class value.+-- An embedded type can only be a field of an entity or another embedded type. For example, the tuples are embedded.+-- 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)+--+--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+--    dbName: Settable                   # Name of the main table+--    autoKey:                           # Description of the autoincremented key for data family Key instance+--      constrName: SettableKey          # Name of constructor+--      default: true                    # The default key is used when entity is referenced without key wrapper. E.g., \"field :: SomeData\" instead of \"field :: Key SomeData keytype\"+--    keys:                              # List of the unique keys. An entity may have unique keys only if it has one constructor+--      - name: someconstraint           # This name references names from uniques field of constructor+--        keyPhantom: Someconstraint     # Name of phantom datatype that corresponds for each unique key+--        constrName: SomeconstraintKey  # Name of data family Key instance constructor for this unique key+--        dbName: Key\#Someconstraint     # It is used for function \"persistName\" of \"PersistField (Key Settable (Unique Someconstraint))\"+--        fields: []                     # Set fields that comprise this unique constraint. It works like setting fields in constructors+--        mkEmbedded: false              # Defines if instance of \"Embedded (Key Settable (Unique Someconstraint))\" will be created. The \"Selector\" constructor names are defined by properties of key fields.+--        default: false                 # Defines if this unique key is used as default+--    constructors:                      # List of constructors. The constructors you don't change can be omitted+--      - name: First                    # Mandatory. Constructor name+--        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+--            dbName: foo                # Column name+--            exprName: FooField         # Name of a field used in expressions+--          - name: bar+--            dbName: bar+--            exprName: BarField+--        uniques:+--          - name: someconstraint+--            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.+--+-- @+--data Company = Company {name :: String, headquarter :: Address, dataCentre :: Address, salesOffice :: Address} deriving (Eq, Show)+--data Address = Address {city :: String, zipCode :: String, street :: String} deriving (Eq, Show)+--+--mkPersist defaultCodegenConfig [groundhog|+--definitions:+--  - entity: Company+--    constructors:+--      - name: Company+--        fields:+--                                        # Property embeddedType of headquarter field is not mentioned, so the corresponding table columns will have names prefixed with headquarter (headquarter$city, headquarter$zip_code, headquarter$street)+--          - name: dataCentre+--            embeddedType:               # If a field has an embedded type you can access its subfields. If you do it, the database columns will match with the embedded dbNames (no prefixing).+--              - name: city              # Just a regular list of fields. However, note that you should use default dbNames of embedded+--                dbName: dc_city+--              - name: zip_code          # Here we use embedded dbName (zip_code) which differs from the name used in Address definition (zipCode) for accessing the field.+--                dbName: dc_zipcode+--              - name: street+--                dbName: dc_street+--          - name: salesOffice+--            embeddedType:               # Similar declaration, but using another syntax for YAML objects+--              - {name: city, dbName: sales_city}+--              - {name: zip_code, dbName: sales_zipcode}+--              - {name: street, dbName: sales_street}+--  - embedded: Address                        +--    fields:                             # The syntax is the same as for constructor fields. Nested embedded types are allowed.+--      - name: city                      # This line does nothing and can be omitted. Default settings for city are not changed.+--      - name: zipCode+--        dbName: zip_code                # Change column name.+--                                        # Street is not mentioned so it will have default settings.+-- |]+-- @++-- | Converts quasiquoted settings into the datatype used by mkPersist.+groundhog :: QuasiQuoter+groundhog = QuasiQuoter { quoteExp  = parseDefinitions+                        , quotePat  = error "groundhog: pattern quasiquoter"+                        , quoteType = error "groundhog: type quasiquoter"+                        , quoteDec  = error "groundhog: declaration quasiquoter"+                        }++-- | Parses configuration stored in the file+--+-- > mkPersist suffixNamingStyle [groundhogFile|../groundhog.yaml|]+groundhogFile :: QuasiQuoter+groundhogFile = quoteFile groundhog++parseDefinitions :: String -> Q Exp+parseDefinitions s = either fail lift result where+  result = decodeEither $ pack s :: Either String PersistDefinitions++mkEntityDecs :: THEntityDef -> Q [Dec]+mkEntityDecs def = do+  --runIO (print def)+  decs <- fmap concat $ sequence+    [ mkEntityPhantomConstructors def+    , mkEntityPhantomConstructorInstances def+    , mkAutoKeyPersistFieldInstance def+    , mkAutoKeyPrimitivePersistFieldInstance def+    , mkEntityUniqueKeysPhantoms def+    , mkUniqueKeysIsUniqueInstances def+    , mkUniqueKeysEmbeddedInstances def+    , mkUniqueKeysPersistFieldInstances def+    , mkUniqueKeysPrimitiveOrPurePersistFieldInstances def+    , mkKeyEqShowInstances def+    , mkEntityPersistFieldInstance def+    , mkEntitySinglePersistFieldInstance def+    , mkPersistEntityInstance def+    , mkEntityNeverNullInstance def+    ]+--  runIO $ putStrLn $ pprint decs+  return decs++mkEmbeddedDecs :: THEmbeddedDef -> Q [Dec]+mkEmbeddedDecs def = do+  --runIO (print def)+  decs <- fmap concat $ sequence+    [ mkEmbeddedPersistFieldInstance def+    , mkEmbeddedPurePersistFieldInstance def+    , mkEmbeddedInstance def+    ]+--  runIO $ putStrLn $ pprint decs+  return decs

+ Database/Groundhog/TH/CodeGen.hs view

@@ -0,0 +1,695 @@+{-# LANGUAGE TemplateHaskell, RecordWildCards, DoAndIfThenElse #-}
+{-# LANGUAGE CPP #-}
+
+module Database.Groundhog.TH.CodeGen
+  ( mkEmbeddedPersistFieldInstance
+  , mkEmbeddedPurePersistFieldInstance
+  , mkEmbeddedInstance
+  , mkEntityPhantomConstructors
+  , mkEntityPhantomConstructorInstances
+  , mkEntityUniqueKeysPhantoms
+  , mkAutoKeyPersistFieldInstance
+  , mkAutoKeyPrimitivePersistFieldInstance
+  , mkUniqueKeysIsUniqueInstances
+  , mkUniqueKeysEmbeddedInstances
+  , mkUniqueKeysPersistFieldInstances
+  , mkUniqueKeysPrimitiveOrPurePersistFieldInstances
+  , mkKeyEqShowInstances
+  , mkEntityPersistFieldInstance
+  , mkEntitySinglePersistFieldInstance
+  , mkPersistEntityInstance
+  , mkEntityNeverNullInstance
+  , mkMigrateFunction
+  ) where
+  
+import Database.Groundhog.Core
+import Database.Groundhog.Generic
+import Database.Groundhog.TH.Settings
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Control.Monad (liftM, liftM2, forM, forM_, foldM, filterM, replicateM)
+import Data.List (findIndex, nub, partition)
+
+mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]
+mkEmbeddedPersistFieldInstance def = do
+  let types = map extractType $ thEmbeddedTypeParams def
+  let embedded = foldl AppT (ConT (embeddedName 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) |]
+    let body = normalB $ fullEmbeddedName
+    let pat = if null types then wildP else varP v
+    funD 'persistName $ [ clause [pat] body [] ]
+
+  -- TODO: remove ([]++) from
+  -- data D a = D a; do { x_a3vQ <- toPersistValues x_a3vP;(return $ (x_a3vQ . ([] ++))) }
+  toPersistValues' <- do
+    vars <- mapM (\f -> newName "x" >>= \fname -> return (fname, fieldType f)) $ embeddedFields def
+    let pat = conP (embeddedConstructorName 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
+          doE $ stmts ++ [noBindS [| return $ $(foldr1 (\a b -> [|$a . $b|]) func) . ($(listE lastPrims')++) |]]
+    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') []]
+
+  fromPersistValues' <- do
+    xs <- newName "xs"
+    failureName <- newName "failure"
+    (isFailureUsed, body) <- mkFromPersistValues failureName xs (embeddedConstructorName def) (embeddedFields def)
+    let failureBody = normalB [| (\a -> fail (failMessage a $(varE xs)) >> return (a, [])) undefined |]
+        failureFunc = funD failureName [clause [] failureBody []]
+        locals = if isFailureUsed then [failureFunc] else []
+    funD 'fromPersistValues [clause [varP xs] (normalB $ return body) locals]
+
+  dbType' <- do
+    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 pat = if null $ thEmbeddedTypeParams def then wildP else varP v
+    funD 'dbType $ [ clause [pat] (normalB [| DbEmbedded $ EmbeddedDef False $(listE $ zipWith mkField [0..] (embeddedFields def)) |]) [] ]
+
+  let context = paramsContext (thEmbeddedTypeParams def) (embeddedFields def)
+  let decs = [persistName', toPersistValues', fromPersistValues', dbType']
+  return $ [InstanceD context (AppT (ConT ''PersistField) embedded) decs]
+
+mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)
+mkFromPersistValues failureName values constrName fieldDefs = let
+    goField xs vars result failure = do
+      (fields, rest) <- spanM (liftM not . isPrim . 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
+      (isFailureUsed, expr) <- goPrim (last xss) rest result failure
+      return (isFailureUsed, doE $ stmts ++ [noBindS expr])
+    goPrim xs vars result failure = do
+      xs' <- newName "xs"
+      (prim, rest) <- spanM (isPrim . snd) vars
+      (isFailureUsed, body') <- case rest of
+        [] -> return (False, [| return ($result, $(varE xs')) |])
+        _  -> goField xs' rest result failure
+      let m = match (foldr (\(fname, _) p -> infixP (varP fname) '(:) p) (varP xs') prim) (normalB body') []
+      return $ if not (null rest || null prim)
+         then (True, caseE (varE xs) [m, failure])
+         else (isFailureUsed, caseE (varE xs) [m])
+    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
+      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
+      (isFailureUsed, body) <- goPrim values vars result failure
+      body' <- if anyPrim then [| phantomDb >>= $(lamE [varP proxy] body) |] else body
+      return (isFailureUsed, body')
+
+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
+    proxy <- newName "p"
+    let pat = conP cName $ map (varP . fst) vars
+    let result = map (\(v, t) -> isPrim t >>= \isP -> if isP then [| (toPrimitivePersistValue $(varE proxy) $(varE v):) |] else [| toPurePersistValues $(varE proxy) $(varE v) |]) vars
+    let body = foldr1 (\a b -> [|$a . $b|]) result
+    funD 'toPurePersistValues [clause [varP proxy, pat] (normalB body) []]
+
+  fromPurePersistValues' <- let
+    goField xs vars result failure proxy = do
+      (fields, rest) <- spanM (liftM not . isPrim . 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 stmts = zipWith3 f xss (tail xss) fields
+      (isFailureUsed, expr) <- goPrim (last xss) rest result failure proxy
+      return (isFailureUsed, letE stmts expr)
+    goPrim xs vars result failure proxy = do
+      xs' <- newName "xs"
+      (prim, rest) <- spanM (isPrim . 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') prim) (normalB body') []
+      return $ if not (null prim)
+         then (True, caseE (varE xs) [m, failure])
+         else (isFailureUsed, caseE (varE xs) [m])
+    mkArg proxy (fname, t) = isPrim t >>= \isP -> (if isP then [| fromPrimitivePersistValue $(varE proxy) $(varE fname) |] else (varE fname))
+    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, fieldType 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
+      let failureFunc = funD failureName [clause [] failureBody []]
+      let locals = if isFailureUsed then [failureFunc] else []
+      funD 'fromPurePersistValues [clause [varP proxy, varP xs] (normalB start) locals]
+
+  let decs = [toPurePersistValues', fromPurePersistValues']
+  return $ [InstanceD context (AppT (ConT ''PurePersistField) dataType) decs]
+
+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
+  context <- paramsPureContext (thEmbeddedTypeParams def) fDefs
+  case context of
+    Nothing -> return []
+    Just context' -> mkPurePersistFieldInstance embedded (embeddedConstructorName 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
+    keyType <- [t| Key $(return entity) BackendSpecific |]
+    
+    persistName' <- do
+      a <- newName "a"
+      let body = [| "Key" ++ [delim] ++ persistName ((undefined :: Key v u -> v) $(varE a)) |]
+      funD 'persistName [clause [varP a] (normalB body) []]
+    toPersistValues' <- funD 'toPersistValues [clause [] (normalB [| primToPersistValue |]) []]
+    fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []]
+    dbType' <- do
+      a <- newName "a"
+      let body = [| DbEntity Nothing $ entityDef ((undefined :: Key v a -> v) $(varE a)) |]
+      funD 'dbType [clause [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 []
+
+mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]
+mkAutoKeyPrimitivePersistFieldInstance def = case thAutoKey def of
+  Just autoKey -> do
+    let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+    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 context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+    let decs = [toPrim', fromPrim']
+    return [InstanceD context (AppT (ConT ''PrimitivePersistField) keyType) decs]
+  _ -> return []
+
+mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]
+mkUniqueKeysIsUniqueInstances def = do
+  let entity = foldl AppT (ConT (dataName 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)) |]
+    uniqueConstr' <- do
+      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
+      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 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) [uniqueConstr', extractUnique', uniqueNum']
+
+mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]
+mkUniqueKeysEmbeddedInstances def = do
+  let entity = foldl AppT (ConT (dataName 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)
+    mkEmbeddedInstance' uniqKeyType (thUniqueKeyFields unique) context
+  
+mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec]
+mkUniqueKeysPersistFieldInstances def = do
+  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  forM (thUniqueKeys def) $ \unique -> do
+    uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
+
+    persistName' <- funD 'persistName [clause [wildP] (normalB $ stringE $ thUniqueKeyDbName unique) []]
+
+    toPersistValues' <- funD 'toPersistValues [clause [] (normalB [| pureToPersistValue |]) []]
+
+    fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| pureFromPersistValue |]) []]
+
+    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 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) []]
+    let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+    let decs = [persistName', toPersistValues', fromPersistValues', dbType']
+    return $ InstanceD context (AppT (ConT ''PersistField) uniqKeyType) decs
+    
+mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]
+mkUniqueKeysPrimitiveOrPurePersistFieldInstances def = do
+  let entity = foldl AppT (ConT (dataName 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
+      else 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)) |]) []]
+        let decs = [toPrim', fromPrim']
+        return [InstanceD context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs]
+      else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context
+
+mkKeyEqShowInstances :: THEntityDef -> Q [Dec]
+mkKeyEqShowInstances def = do
+  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  let mkShowInstance typ cName fieldsNum = do
+      showsPrec' <- do
+        p <- newName "p"
+        fields <- replicateM fieldsNum (newName "x")
+        let pat = conP (mkName cName) $ map varP fields
+        --let shownArgs = foldr1 (\a b -> [| $a ++ $b |]) $ map (\a -> [| show $(varE a) |]) fields
+        --let body = [| $(lift $ cName ++ " ") ++ $shownArgs |]
+        
+        let showC = [| showString $(lift $ cName ++ " ") |]
+        let showArgs = foldr1 (\a b -> [| $a . showString " " . $b |]) $ map (\a -> [| showsPrec 11 $(varE a) |]) fields
+        let body = [| showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs) |]
+        funD 'showsPrec [clause [varP p, pat] (normalB body) []]
+      let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+      let decs = [showsPrec']
+      return $ InstanceD context (AppT (ConT ''Show) typ) decs
+  let mkEqInstance typ cName fieldsNum = do
+      eq' <- do
+        let fields = replicateM fieldsNum (newName "x")
+        (fields1, fields2) <- liftM2 (,) fields fields
+        let mkPat = conP (mkName cName) . map varP
+        let body = foldr1 (\e1 e2 -> [| $e1 && $e2 |]) $ zipWith (\n1 n2 -> [| $(varE n1) == $(varE n2) |]) fields1 fields2
+        funD '(==) [clause [mkPat fields1, mkPat fields2] (normalB body) []]
+      let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+      let decs = [eq']
+      return $ InstanceD context (AppT (ConT ''Eq) typ) decs
+    
+  autoKeyInstance <- case thAutoKey def of
+    Nothing -> return []
+    Just autoKey -> do
+      keyType <- [t| Key $(return entity) BackendSpecific |]
+      mapM (\f -> f keyType (thAutoKeyConstrName autoKey) 1) [mkShowInstance, mkEqInstance]
+  uniqsInstances <- forM (thUniqueKeys def) $ \unique -> do
+    uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |]
+    let fieldsNum = length $ thUniqueKeyFields unique
+    mapM (\f -> f uniqKeyType (thUniqueKeyConstrName unique) fieldsNum) [mkShowInstance, mkEqInstance]
+  return $ autoKeyInstance ++ concat uniqsInstances
+
+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
+  
+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) []
+    return $ DataInstD [] ''Selector [dataType, VarT fParam] (map mkField fDefs) []
+
+  selectorNum' <- do
+    let mkClause fNum field = clause [conP (mkName $ exprName field) []] (normalB $ lift fNum) []
+    let clauses = zipWith mkClause [0 :: Int ..] fDefs
+    funD 'selectorNum clauses
+
+  let decs = [selector', selectorNum']
+  return $ [InstanceD context (AppT (ConT ''Embedded) dataType) decs]
+
+mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]
+mkEntityPhantomConstructors def = do
+  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+  forM (thConstructors def) $ \c -> do
+    v <- newName "v"
+    let name = mkName $ thPhantomConstrName c
+    phantom <- [t| ConstructorMarker $(return entity) |]
+    let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name []
+    dataD (cxt []) name [PlainTV v] [return constr] []
+  
+mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]
+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) []]
+    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
+  forM (thUniqueKeys def) $ \u -> do
+    v <- newName "v"
+    let name = mkName $ thUniqueKeyPhantomName u
+    phantom <- [t| UniqueMarker $(return entity) |]
+    let constr = ForallC (thTypeParams def) [EqualP (VarT v) phantom] $ NormalC name []
+    dataD (cxt []) name [PlainTV v] [return constr] []
+    
+mkPersistEntityInstance :: THEntityDef -> Q [Dec]
+mkPersistEntityInstance def = do
+  let entity = foldl AppT (ConT (dataName def)) $ map extractType $ thTypeParams def
+
+  key' <- do
+    uParam <- newName "u"
+    autoKey <- case thAutoKey def of
+      Nothing -> return []
+      Just k -> do
+        keyDescr <- [t| BackendSpecific |]
+        return [ForallC [] [EqualP (VarT uParam) keyDescr] $ NormalC (mkName $ thAutoKeyConstrName k) [(NotStrict, ConT ''PersistValue)]]
+    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
+      return $ ForallC [] [EqualP (VarT uParam) uniqType] $ NormalC (mkName $ thUniqueKeyConstrName unique) uniqFields'
+    return $ DataInstD [] ''Key [entity, VarT uParam] (autoKey ++ uniques) []
+
+  autoKey' <- do
+    autoType <- case thAutoKey def of
+      Nothing -> conT ''()
+      Just k -> [t| Key $(return entity) BackendSpecific |]
+    return $ TySynInstD ''AutoKey [entity] autoType
+    
+  defaultKey' <- do
+    let keyType = case thAutoKey def of
+         Just k | thAutoKeyIsDef k -> [t| BackendSpecific |]
+         _ -> let unique = head $ filter thUniqueKeyIsDef $ thUniqueKeys def
+              in  [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName unique) |]
+    typ <- [t| Key $(return entity) $keyType |]
+    return $ TySynInstD ''DefaultKey [entity] typ
+  
+  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 f cdef = map (mkField $ mkName $ thPhantomConstrName cdef) $ thConstrFields cdef
+    let constrs = concatMap f $ thConstructors def
+    return $ DataInstD [] ''Field [entity, VarT cParam, VarT fParam] constrs []
+    
+  entityDef' <- do
+    v <- newName "v"
+    let mkLambda t = [|undefined :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return t) |]) |]
+    let types = map extractType $ thTypeParams def
+    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 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) |]
+          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) |]
+
+    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
+    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) (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
+          doE $ stmts ++ [noBindS [| return $ (toPrimitivePersistValue $(varE proxy) (cNum :: Int):) . $(foldr1 (\a b -> [|$a . $b|]) func) . ($(listE lastPrims')++) |]]
+    let body' = [| phantomDb >>= $(lamE [varP proxy] body) |]
+    clause [pat] (normalB body') []
+
+  fromEntityPersistValues' <- do
+      xs <- newName "xs"
+      let failureBody = normalB [| (\a -> fail (failMessage a $(varE xs)) >> return (a, [])) undefined |]
+      failureName <- newName "failure"
+      let failure = match wildP (normalB $ varE failureName) []
+      matches <- forM (zip [0..] (thConstructors def)) $ \(cNum, c) -> do
+        let cNum' = conP 'PersistInt64 [litP $ integerL cNum]
+        xs' <- newName "xs"
+        (_, body) <- mkFromPersistValues failureName xs' (thConstrName c) (thConstrFields c)
+        return $ match (infixP cNum' '(:) (varP xs')) (normalB $ return body) []
+      let start = caseE (varE xs) $ matches ++ [failure]
+      let failureFunc = funD failureName [clause [] failureBody []]
+      funD 'fromEntityPersistValues [clause [varP xs] (normalB start) [failureFunc]]
+
+  --TODO: support constraints with embedded datatypes fields
+  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
+      pats = map (const wildP) $ thConstrFields cdef
+    mkClause cNum cdef = do
+      let allConstrainedFields = concatMap psUniqueFields $ thConstrUniques cdef
+      names <- mapM (\name -> newName name >>= \name' -> return (name, name `elem` allConstrainedFields, name')) $ map fieldName $ thConstrFields cdef
+      proxy <- newName "p"
+      let body = normalB $ [| (cNum, $(listE $ map (\(PSUniqueDef cname fnames) -> [|(cname, $(listE $ map (\fname -> [| toPrimitivePersistValue $(varE proxy) $(varE $ getFieldName fname) |] ) fnames )) |] ) $ thConstrUniques cdef)) |]
+          getFieldName name = case filter (\(a, _, _) -> a == name) names of
+            [(_, _, name')] -> name'
+            []  -> error $ "Database field name " ++ show name ++ " declared in constraint not found"
+            _   -> error $ "It can never happen. Found several fields with one database name " ++ show name
+          pattern = map (\(_, isConstrained, name') -> if isConstrained then varP name' else wildP) names
+      clause [varP proxy, conP (thConstrName cdef) pattern] 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
+    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), []) |]
+        return (fArg, body)
+    in funD 'entityFieldChain clauses
+
+  let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+  let decs = [key', autoKey', defaultKey', fields', entityDef', toEntityPersistValues', fromEntityPersistValues', getUniques', entityFieldChain']
+  return $ [InstanceD context (AppT (ConT ''PersistEntity) entity) decs]
+
+mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]
+mkEntityPersistFieldInstance def = do
+  let types = map extractType $ thTypeParams def
+  let entity = foldl AppT (ConT (dataName def)) types
+  
+  persistName' <- do
+    v <- newName "v"
+    let mkLambda t = [|undefined :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return t) |]) |]
+    
+    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) |]
+    let body = normalB $ fullEntityName
+    let pat = if null types then wildP else varP v
+    funD 'persistName $ [ clause [pat] body [] ]
+  
+  isOne <- isDefaultKeyOneColumn def
+  let uniqInfo = either auto uniq $ getDefaultKey def where
+      auto _ = Nothing
+      uniq u = let name = mkName $ thUniqueKeyPhantomName u in Just $ (conT name, conE name)
+
+  toPersistValues' <- do
+    let body = normalB $ case uniqInfo of
+         _ | isOne -> [| singleToPersistValue |]
+         Just u    -> [| toPersistValuesUnique $(snd u) |]
+         _         -> error "mkEntityPersistFieldInstance: key has no unique type"
+    funD 'toPersistValues $ [ clause [] body [] ]
+
+  fromPersistValue' <- do
+    let body = normalB $ case uniqInfo of
+         _ | isOne -> [| singleFromPersistValue |]
+         Just u    -> [| fromPersistValuesUnique $(snd u) |]
+         _         -> error "mkEntityPersistFieldInstance: key has no unique type"
+    funD 'fromPersistValues $ [ clause [] body []]
+
+  dbType' <- do
+    x <- newName "x"
+    let keyType = maybe [t| BackendSpecific |] (\(u, _) -> [t| Unique $u |]) uniqInfo
+    funD 'dbType $ [clause [varP x] (normalB [| dbType $ (undefined :: a -> Key a $keyType) $(varE x) |]) []]
+
+  let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+  let decs = [persistName', toPersistValues', fromPersistValue', dbType']
+  return $ [InstanceD context (AppT (ConT ''PersistField) entity) decs]
+
+mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]
+mkEntitySinglePersistFieldInstance def = isDefaultKeyOneColumn def >>= \isOne ->
+  if isOne
+    then do
+      toSinglePersistValue' <- funD 'toSinglePersistValue $ [ clause [] (normalB to) [] ]
+      fromSinglePersistValue' <- funD 'fromSinglePersistValue $ [ clause [] (normalB from) []]
+      let decs = [toSinglePersistValue', fromSinglePersistValue']
+      return [InstanceD context (AppT (ConT ''SinglePersistField) entity) decs]
+    else return [] where
+    (to, from) = case getDefaultKey def of
+      Left  _ -> ([| toSinglePersistValueAutoKey |], [| fromSinglePersistValueAutoKey |])
+      Right k -> ([| toSinglePersistValueUnique $u |], [| fromSinglePersistValueUnique $u |]) where
+        u = conE $ mkName $ thUniqueKeyPhantomName k
+    types = map extractType $ thTypeParams def
+    entity = foldl AppT (ConT (dataName 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 context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)
+  isOne <- isDefaultKeyOneColumn def
+  return $ if isOne
+    then [InstanceD context (AppT (ConT ''NeverNull) entity) []]
+    else []
+
+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
+  sig <- sigD (mkName name) [t| PersistBackend m => Migration m |]
+  func <- funD (mkName name) [clause [] (normalB body) []]
+  return [sig, func]
+
+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
+    else return False
+
+getDefaultKey :: THEntityDef -> Either THAutoKeyDef THUniqueKeyDef
+getDefaultKey def = case thAutoKey def of
+  Just k | thAutoKeyIsDef k -> Left k
+  _ -> Right $ head $ filter thUniqueKeyIsDef $ thUniqueKeys def
+
+paramsContext :: [TyVarBndr] -> [THFieldDef] -> Cxt
+paramsContext types fields = classPred ''PersistField params ++ classPred ''SinglePersistField maybys ++ classPred ''NeverNull maybys where
+  classPred clazz = map (\t -> ClassP clazz [t])
+  -- every type must be an instance of PersistField
+  params = map extractType types
+  -- 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
+
+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
+  return $ case invalid of
+    [] -> Just $ classPred ''PurePersistField params ++ classPred ''PrimitivePersistField maybys ++ classPred ''NeverNull maybys where
+          params = map extractType types
+          classPred clazz = map (\t -> ClassP clazz [t])
+          -- 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
+    _  -> Nothing
+
+extractType :: TyVarBndr -> Type
+extractType (PlainTV name) = VarT name
+extractType (KindedTV name _) = VarT name
+
+#if MIN_VERSION_template_haskell(2, 7, 0)
+#define isClassInstance isInstance
+#endif
+
+isPrim :: Type -> Q Bool
+-- we cannot use simply isClassInstance because it crashes on type vars and in this case
+-- class PrimitivePersistField a
+-- instance PrimitivePersistField Int
+-- instance PrimitivePersistField a => Maybe a
+-- it will consider (Maybe anytype) instance of PrimitivePersistField
+isPrim t | hasFreeVars t = return False
+isPrim t@(ConT _) = isClassInstance ''PrimitivePersistField [t]
+--isPrim (AppT (ConT key) _)  | key == ''Key = return True
+isPrim (AppT (AppT (ConT key) _) (AppT (AppT _ (ConT typ)) _))  | key == ''Key && typ == ''BackendSpecific  = return True
+isPrim (AppT (ConT tcon) t) | tcon == ''Maybe = isPrim t
+isPrim _ = return False
+
+foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a
+foldType f (<>) = go where
+  go (ForallT _ _ _) = error "forall'ed fields are not allowed"
+  go z@(AppT a b)    = f z <> go a <> go b
+  go z@(SigT t _)    = f z <> go t
+  go z               = f z
+
+hasFreeVars :: Type -> Bool
+hasFreeVars = foldType f (||) where
+  f (VarT _) = True
+  f _ = False
+
+insideMaybe :: Type -> [Type]
+insideMaybe = foldType f (++) where
+  f (AppT (ConT c) t@(VarT _)) | c == ''Maybe = [t]
+  f _ = []
+
+spanM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
+spanM p = go  where
+  go [] = return ([], [])
+  go (x:xs) = do
+    flg <- p x
+    if flg then do
+        (ys, zs) <- go xs
+        return (x:ys, zs)
+      else return ([], x:xs)

+ Database/Groundhog/TH/Settings.hs view

@@ -0,0 +1,219 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, OverloadedStrings, RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Database.Groundhog.TH.Settings
+  ( PersistDefinitions(..)
+  , THEntityDef(..)
+  , THEmbeddedDef(..)
+  , THConstructorDef(..)
+  , THFieldDef(..)
+  , THUniqueKeyDef(..)
+  , THAutoKeyDef(..)
+  , PSEntityDef(..)
+  , PSEmbeddedDef(..)
+  , PSConstructorDef(..)
+  , PSFieldDef(..)
+  , PSEmbeddedFieldDef(..)
+  , PSUniqueDef(..)
+  , PSUniqueKeyDef(..)
+  , PSAutoKeyDef(..)
+  ) where
+
+import Database.Groundhog.Generic (PSEmbeddedFieldDef(..))
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Control.Applicative
+import Control.Monad (mzero)
+import Data.Yaml
+
+data PersistDefinitions = PersistDefinitions {definitions :: [Either PSEntityDef PSEmbeddedDef]} deriving Show
+
+-- 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
+  , thAutoKey :: Maybe THAutoKeyDef
+  , thUniqueKeys :: [THUniqueKeyDef]
+  , thTypeParams :: [TyVarBndr]
+  , thConstructors :: [THConstructorDef]
+} deriving Show
+
+data THAutoKeyDef = THAutoKeyDef {
+    thAutoKeyConstrName :: String
+  , thAutoKeyIsDef :: Bool
+} deriving Show
+
+data THEmbeddedDef = THEmbeddedDef {
+    embeddedName :: Name
+  , embeddedConstructorName :: Name
+  , dbEmbeddedName :: String -- used only to set polymorphic part of name of its container
+  , thEmbeddedTypeParams :: [TyVarBndr]
+  , embeddedFields :: [THFieldDef]
+} deriving Show
+
+data THConstructorDef = THConstructorDef {
+    thConstrName    :: Name -- U2
+  , thPhantomConstrName :: String -- U2Constructor
+  , dbConstrName    :: String -- SQLU2
+  , thDbAutoKeyName :: Maybe String -- u2_id
+  , thConstrFields  :: [THFieldDef]
+  , thConstrUniques :: [PSUniqueDef]
+} deriving Show
+
+data THFieldDef = THFieldDef {
+    fieldName :: String -- bar
+  , dbFieldName :: String -- SQLbar
+  , exprName :: String -- BarField
+  , fieldType :: Type
+  , embeddedDef :: Maybe [PSEmbeddedFieldDef]
+} deriving Show
+
+data THUniqueKeyDef = THUniqueKeyDef {
+    thUniqueKeyName :: String
+  , thUniqueKeyPhantomName :: String
+  , thUniqueKeyConstrName :: String
+  , thUniqueKeyDbName :: String -- used only to set polymorphic part of name of its container
+  , thUniqueKeyFields :: [THFieldDef]
+  , thUniqueKeyMakeEmbedded :: Bool -- whether to make it an instance of Embedded
+  , thUniqueKeyIsDef :: Bool
+} deriving Show
+
+data PSEntityDef = PSEntityDef {
+    psDataName :: String -- SomeData
+  , psDbEntityName :: Maybe String  -- SQLSomeData
+  , psAutoKey :: Maybe (Maybe PSAutoKeyDef) -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings
+  , psUniqueKeys :: Maybe [PSUniqueKeyDef]
+  , psConstructors :: Maybe [PSConstructorDef]
+} deriving Show
+
+data PSEmbeddedDef = PSEmbeddedDef {
+    psEmbeddedName :: String
+  , psDbEmbeddedName :: Maybe String -- used only to set polymorphic part of name of its container
+  , psEmbeddedFields :: Maybe [PSFieldDef]
+} deriving Show
+
+data PSConstructorDef = PSConstructorDef {
+    psConstrName :: String -- U2
+  , psPhantomConstrName :: Maybe String -- U2Constructor
+  , psDbConstrName :: Maybe String -- SQLU2
+  , psDbAutoKeyName :: Maybe (Maybe String) -- u2_id
+  , psConstrFields  :: Maybe [PSFieldDef]
+  , psConstrUniques :: Maybe [PSUniqueDef]
+} deriving Show
+
+data PSFieldDef = PSFieldDef {
+    psFieldName :: String -- bar
+  , psDbFieldName :: Maybe String -- SQLbar
+  , psExprName :: Maybe String -- BarField
+  , psEmbeddedDef :: Maybe [PSEmbeddedFieldDef]
+} deriving Show
+
+data PSUniqueDef = PSUniqueDef {
+    psUniqueName :: String
+  , psUniqueFields :: [String]
+} deriving Show
+
+data PSUniqueKeyDef = PSUniqueKeyDef {
+    psUniqueKeyName :: String
+  , psUniqueKeyPhantomName :: Maybe String
+  , psUniqueKeyConstrName :: Maybe String
+  , psUniqueKeyDbName :: Maybe String
+  , psUniqueKeyFields :: Maybe [PSFieldDef]
+  , psUniqueKeyMakeEmbedded :: Maybe Bool
+  , psUniqueKeyIsDef :: Maybe Bool
+} deriving Show
+
+data PSAutoKeyDef = PSAutoKeyDef {
+    psAutoKeyConstrName :: Maybe String
+  , psAutoKeyIsDef :: Maybe Bool
+} deriving Show
+
+instance Lift PersistDefinitions where
+  lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift definitions) |]
+
+instance Lift PSEntityDef where
+  lift (PSEntityDef {..}) = [| PSEntityDef $(lift psDataName) $(lift psDbEntityName) $(lift psAutoKey) $(lift psUniqueKeys) $(lift psConstructors) |]
+
+instance Lift PSEmbeddedDef where
+  lift (PSEmbeddedDef {..}) = [| PSEmbeddedDef $(lift psEmbeddedName) $(lift psDbEmbeddedName) $(lift psEmbeddedFields) |]
+
+instance Lift PSConstructorDef where
+  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) |]
+
+instance Lift PSFieldDef where
+  lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psExprName) $(lift psEmbeddedDef) |]
+
+instance Lift PSEmbeddedFieldDef where
+  lift (PSEmbeddedFieldDef {..}) = [| PSEmbeddedFieldDef $(lift psEmbeddedFieldName) $(lift psDbEmbeddedFieldName) $(lift psSubEmbedded) |]
+
+instance Lift PSUniqueKeyDef where
+  lift (PSUniqueKeyDef {..}) = [| PSUniqueKeyDef $(lift psUniqueKeyName) $(lift psUniqueKeyPhantomName) $(lift psUniqueKeyConstrName) $(lift psUniqueKeyDbName) $(lift psUniqueKeyFields) $(lift psUniqueKeyMakeEmbedded) $(lift psUniqueKeyIsDef) |]
+
+instance Lift PSAutoKeyDef where
+  lift (PSAutoKeyDef {..}) = [| PSAutoKeyDef $(lift psAutoKeyConstrName) $(lift psAutoKeyIsDef) |]
+
+instance FromJSON PersistDefinitions where
+  {- it allows omitting parts of the settings file. All these forms are possible:
+        definitions:
+          - entity:name
+        ---
+          - entity:name
+        ---
+          entity: name
+  -}
+  parseJSON value = PersistDefinitions <$> case value of
+    Object v -> do
+      defs <- v .:? "definitions"
+      case defs of
+        Just defs'@(Array _) -> parseJSON defs'
+        Just _ -> mzero
+        Nothing -> fmap (\a -> [a]) $ parseJSON value
+    defs@(Array _) -> parseJSON defs
+    _ -> mzero
+
+instance FromJSON (Either PSEntityDef PSEmbeddedDef) where
+  parseJSON obj@(Object v) = do
+    entity   <- v .:? "entity"
+    embedded <- v .:? "embedded"
+    case (entity, embedded) of
+      (Just _, Nothing) -> fmap Left $ parseJSON obj
+      (Nothing, Just _) -> fmap Right $ parseJSON obj
+      (Just entName, Just embName) -> fail $ "Record has both entity name " ++ entName ++ " and embedded name " ++ embName
+      (Nothing, Nothing) -> fail "Record must have either entity name or embedded name"
+  parseJSON _          = mzero
+
+instance FromJSON PSEntityDef where
+  parseJSON (Object v) = PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors"
+  parseJSON _          = mzero
+
+instance FromJSON PSEmbeddedDef where
+  parseJSON (Object v) = PSEmbeddedDef <$> v .: "embedded" <*> v .:? "dbName" <*> v .:? "fields"
+  parseJSON _          = mzero
+
+instance FromJSON PSConstructorDef where
+  parseJSON (Object v) = PSConstructorDef <$> v .: "name" <*> v .:? "phantomName" <*> v .:? "dbName" <*> v .:? "keyDbName" <*> v .:? "fields" <*> v .:? "uniques"
+  parseJSON _          = mzero
+
+instance FromJSON PSUniqueDef where
+  parseJSON (Object v) = PSUniqueDef <$> v .: "name" <*> v .: "fields"
+  parseJSON _          = mzero
+
+instance FromJSON PSFieldDef where
+  parseJSON (Object v) = PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "exprName" <*> v .:? "embeddedType"
+  parseJSON _          = mzero
+
+instance FromJSON PSEmbeddedFieldDef where
+  parseJSON (Object v) = PSEmbeddedFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "embeddedType"
+  parseJSON _          = mzero
+
+instance FromJSON PSUniqueKeyDef where
+  parseJSON (Object v) = PSUniqueKeyDef <$> v .: "name" <*> v .:? "keyPhantom" <*> v .:? "constrName" <*> v .:? "dbName" <*> v .:? "fields" <*> v .:? "mkEmbedded" <*> v .:? "default"
+  parseJSON _          = mzero
+
+instance FromJSON PSAutoKeyDef where
+  parseJSON (Object v) = PSAutoKeyDef <$> v .:? "constrName" <*> v .:? "default"
+  parseJSON _          = mzero

+ LICENSE view

@@ -0,0 +1,10 @@+Copyright (c) 2012, Boris Lykah+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * Neither the name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ groundhog-th.cabal view

@@ -0,0 +1,29 @@+name:            groundhog-th+version:         0.1.0+license:         BSD3+license-file:    LICENSE+author:          Boris Lykah <lykahb@gmail.com>+maintainer:      Boris Lykah <lykahb@gmail.com>+synopsis:        Type-safe ADT-database mapping library.+description:     This library helps to generate boilerplate for Groundhog datatypes+category:        Database+stability:       Non-stable+cabal-version:   >= 1.6+build-type:      Simple++library+    build-depends:   base                     >= 4         && < 5+                   , bytestring               >= 0.9       && < 0.10+                   , groundhog                >= 0.1.0     && < 0.2.0+                   , template-haskell+                   , time                     >= 1.1.4+                   , containers               >= 0.2       && < 0.5+                   , yaml                     >= 0.6.1     && < 0.8+    exposed-modules: Database.Groundhog.TH+                     Database.Groundhog.TH.Settings+                     Database.Groundhog.TH.CodeGen+    ghc-options:     -Wall+    +source-repository head+  type:     git+  location: git://github.com/lykahb/groundhog.git