{-# 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
  , defaultMkEntityDecs
  , defaultMkEmbeddedDecs
  , defaultMkPrimitiveDecs
  -- $namingStylesDoc
  , NamingStyle(..)
  , suffixNamingStyle
  , persistentNamingStyle
  , conciseNamingStyle
  , lowerCaseSuffixNamingStyle
  , toUnderscore
  , firstChar
  -- * Utility functions
  , mkTHEntityDef
  , mkTHEmbeddedDef
  , mkTHPrimitiveDef
  , applyEntitySettings
  , applyEmbeddedSettings
  , applyPrimitiveSettings
  ) where

import Database.Groundhog.Core (delim, UniqueType(..))
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.Applicative
import Control.Monad (forM, forM_, when, unless, liftM2)
import Data.Char (isUpper, isLower, isSpace, isDigit, toUpper, toLower)
import Data.List (nub, (\\))
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.String
import Data.Text.Encoding (encodeUtf8)
import Data.Yaml as Y (decodeHelper, ParseException(..))
import qualified Text.Libyaml as Y

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
  -- | Functions that produce Haskell code for the entities. In most cases when overriding, the default functions that produce mappings are not replaced but kept along with custom code. Example: @['defaultMkEntityDecs', mkMyDecs]@.
  , mkEntityDecs :: [[THEntityDef] -> Q [Dec]]
  , mkEmbeddedDecs :: [[THEmbeddedDef] -> Q [Dec]]
  , mkPrimitiveDecs :: [[THPrimitiveDef] -> Q [Dec]]
}

defaultCodegenConfig :: CodegenConfig
defaultCodegenConfig = CodegenConfig suffixNamingStyle Nothing [defaultMkEntityDecs] [defaultMkEmbeddedDecs] [defaultMkPrimitiveDecs]

-- $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 -> firstChar toUpper uName
  , mkUniqueKeyConstrName = \_ _ uName -> firstChar toUpper uName ++ "Key"
  , mkUniqueKeyDbName = \_ _ uName -> "Key" ++ [delim] ++ firstChar toUpper uName
  , mkDbConstrName = \_ cName _ -> cName
  , mkDbConstrAutoKeyName = \_ _ _ -> "id"
  , mkDbFieldName = \_ _ _ fName _ -> fName
  , mkExprFieldName = \_ _ _ fName _ -> firstChar toUpper fName ++ "Field"
  , mkExprSelectorName = \_ _ fName _ -> firstChar toUpper fName ++ "Selector"
  , mkNormalFieldName = \_ cName _ fNum -> firstChar toLower cName ++ show fNum
  , mkNormalDbFieldName = \_ cName _ fNum -> firstChar 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 ++ firstChar toUpper fName
  , mkExprSelectorName = \_ cName fName _ -> cName ++ firstChar 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 _ -> firstChar toUpper fName
  , mkExprSelectorName = \_ _ fName _ -> firstChar toUpper fName
  , mkNormalExprFieldName = \_ cName _ fNum -> cName ++ show fNum
  , mkNormalExprSelectorName = \_ cName fNum -> cName ++ show fNum
}

-- | The generated Haskell names of phantom types (constructors, fields, etc.) are the same as with suffixNamingStyle. But the table names and columns are converted from camelCase to underscore_lower_case with `toUnderscore`.
lowerCaseSuffixNamingStyle :: NamingStyle
lowerCaseSuffixNamingStyle = suffixNamingStyle {
    mkDbEntityName = \dName -> toUnderscore dName
  , mkDbConstrName = \_ cName _ -> toUnderscore cName
  , mkDbFieldName = \_ _ _ fName _ -> toUnderscore fName
  , mkNormalDbFieldName = \_ cName _ fNum -> toUnderscore $ 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{..} = do
  let duplicates = notUniqueBy id $ 
        map psDataName psEntities ++ map psEmbeddedName psEmbeddeds ++ map psPrimitiveName psPrimitives
  unless (null duplicates) $ fail $ "All definitions must be unique. Found duplicates: " ++ show duplicates
  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
          _        -> error $ "Only datatypes can be processed: " ++ name
      
  entities   <- forM psEntities $ \e ->
    either error id . validateEntity   . applyEntitySettings namingStyle e . mkTHEntityDef namingStyle    <$> getDecl (psDataName e)
  embeddeds  <- forM psEmbeddeds $ \e ->
    either error id . validateEmbedded . applyEmbeddedSettings e           . mkTHEmbeddedDef namingStyle  <$> getDecl (psEmbeddedName e)
  primitives <- forM psPrimitives $ \e ->
                                         applyPrimitiveSettings e          . mkTHPrimitiveDef namingStyle <$> getDecl (psPrimitiveName e)
  let mkEntityDecs' = maybe id (\name -> (mkMigrateFunction name:)) migrationFunction $ mkEntityDecs
  fmap concat $ sequence $ map ($ entities) mkEntityDecs' ++ map ($ embeddeds) mkEmbeddedDecs ++ map ($ primitives) mkPrimitiveDecs

applyEntitySettings :: NamingStyle -> PSEntityDef -> THEntityDef -> THEntityDef
applyEntitySettings style PSEntityDef{..} def@(THEntityDef{..}) =
  def { thDbEntityName = fromMaybe thDbEntityName psDbEntityName
      , thEntitySchema = psEntitySchema
      , thAutoKey = thAutoKey'
      , thUniqueKeys = maybe thUniqueKeys (map mkUniqueKey') psUniqueKeys
      , thConstructors = thConstructors'
      } where
  thAutoKey' = maybe thAutoKey (liftM2 applyAutoKeySettings thAutoKey) psAutoKey
  thConstructors' = maybe thConstructors'' (f thConstructors'') $ psConstructors where
    thConstructors'' = map checkAutoKey thConstructors
    checkAutoKey cDef@(THConstructorDef{..}) = cDef {thDbAutoKeyName = thAutoKey' >> thDbAutoKeyName}

  mkUniqueKey' = mkUniqueKey style (nameBase thDataName) (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 thFieldName applyFieldSettings
  uniqueFields = mkFieldsForUniqueKey style dName key cDef

applyAutoKeySettings :: THAutoKeyDef -> PSAutoKeyDef -> THAutoKeyDef
applyAutoKeySettings def@(THAutoKeyDef{..}) PSAutoKeyDef{..} = 
  def { thAutoKeyConstrName = fromMaybe thAutoKeyConstrName psAutoKeyConstrName
      , thAutoKeyIsDef = fromMaybe thAutoKeyIsDef psAutoKeyIsDef
      }

applyConstructorSettings :: PSConstructorDef -> THConstructorDef -> THConstructorDef
applyConstructorSettings PSConstructorDef{..} def@(THConstructorDef{..}) =
  def { thPhantomConstrName = fromMaybe thPhantomConstrName psPhantomConstrName
      , thDbConstrName = fromMaybe thDbConstrName psDbConstrName
      , thDbAutoKeyName = psDbAutoKeyName <|> thDbAutoKeyName
      , thConstrFields = maybe thConstrFields (f thConstrFields) psConstrFields
      , thConstrUniques = maybe thConstrUniques (map convertUnique) psConstrUniques
      } where
  f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings
  convertUnique (PSUniqueDef uName uType uFields) = THUniqueDef uName (fromMaybe UniqueConstraint uType) uFields
  
applyFieldSettings :: PSFieldDef String -> THFieldDef -> THFieldDef
applyFieldSettings PSFieldDef{..} def@(THFieldDef{..}) =
  def { thDbFieldName = fromMaybe thDbFieldName psDbFieldName
      , thExprName = fromMaybe thExprName psExprName
      , thDbTypeName = psDbTypeName
      , thEmbeddedDef = psEmbeddedDef
      , thDefaultValue = psDefaultValue
      , thReferenceParent = psReferenceParent
      }

applyEmbeddedSettings :: PSEmbeddedDef -> THEmbeddedDef -> THEmbeddedDef
applyEmbeddedSettings PSEmbeddedDef{..} def@(THEmbeddedDef{..}) =
  def { thDbEmbeddedName = fromMaybe thDbEmbeddedName psDbEmbeddedName
      , thEmbeddedFields = maybe thEmbeddedFields (f thEmbeddedFields) psEmbeddedFields
      } where
  f = foldr $ replaceOne "field" psFieldName thFieldName applyFieldSettings

applyPrimitiveSettings :: PSPrimitiveDef -> THPrimitiveDef -> THPrimitiveDef
applyPrimitiveSettings PSPrimitiveDef{..} def@(THPrimitiveDef{..}) =
  def { thPrimitiveDbName = fromMaybe thPrimitiveDbName psPrimitiveDbName
      , thPrimitiveStringEnumRepresentation = fromMaybe thPrimitiveStringEnumRepresentation psPrimitiveStringEnumRepresentation
      }

mkFieldsForUniqueKey :: NamingStyle -> String -> THUniqueKeyDef -> THConstructorDef -> [THFieldDef]
mkFieldsForUniqueKey style dName uniqueKey cDef = zipWith (setSelector . findField) (thUniqueFields uniqueDef) [0..] where
  findField (Left name) = findOne "field" thFieldName name $ thConstrFields cDef
  findField (Right expr) = error $ "A unique key may not contain expressions: " ++ expr
  uniqueDef = findOne "unique" thUniqueName (thUniqueKeyName uniqueKey) $ thConstrUniques cDef
  setSelector f i = f {thExprName = mkExprSelectorName style dName (thUniqueKeyConstrName uniqueKey) (thFieldName f) i}

notUniqueBy :: Eq b => (a -> b) -> [a] -> [b]
notUniqueBy f xs = let xs' = map f xs in nub $ xs' \\ nub xs'

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 thDbConstrName constrs "constructor db name"
  forM_ constrs $ \cdef -> do
    let fields = thConstrFields cdef
    assertSpaceFree (thPhantomConstrName cdef) "constructor phantom name"
    assertUnique thExprName fields "expr field name in a constructor"
    assertUnique thDbFieldName fields "db field name in a constructor"
    mapM_ validateField fields
    case filter (\(THUniqueDef _ _ uFields) -> null uFields) $ thConstrUniques cdef of
      [] -> return ()
      ys -> fail $ "Constraints must have at least one field: " ++ show ys
    when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $
      fail $ "Presence of autokey definitions should be the same in entity and constructors definitions " ++ show (thDataName def) ++ ": " ++ show (thDbAutoKeyName cdef) ++ " - " ++ show (thAutoKey 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 (thDataName def)
    else -- check that all unique keys reference existing uniques
         let uniqueNames = map thUniqueName $ thConstrUniques $ head constrs
         in  forM_ (thUniqueKeys def) $ \cKey -> unless (thUniqueKeyName cKey `elem` uniqueNames) $
             fail $ "Unique key mentions unknown unique: " ++ thUniqueKeyName cKey ++ " in datatype " ++ show (thDataName def)
  let isPrimary x = case x of
            UniquePrimary _ -> True
            _ -> False
      primaryConstraints = length $ filter (isPrimary . thUniqueType) $ concatMap thConstrUniques constrs 
  if length constrs > 1
    then when (primaryConstraints > 0) $
           fail $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def)
    else when (primaryConstraints + maybe 0 (const 1) (thAutoKey def) > 1) $
           fail $ "A datatype cannot have more than one primary key constraint: " ++ show (thDataName def)
  -- check that only one of the keys is default
  let keyDefaults = maybe id ((:) . thAutoKeyIsDef) (thAutoKey def) $ map thUniqueKeyIsDef (thUniqueKeys def)
  when (not (null keyDefaults) && length (filter id keyDefaults) /= 1) $
    fail $ "A datatype with keys must have one default key: " ++ show (thDataName def)
  return def
  
validateField :: THFieldDef -> Either String ()
validateField fDef = do
  assertSpaceFree (thExprName fDef) "field expr name"
  when (isJust (thDbTypeName fDef) && isJust (thEmbeddedDef fDef)) $
    fail $ "A field may not have both type and embeddedType: " ++ show (thFieldName fDef)

validateEmbedded :: THEmbeddedDef -> Either String THEmbeddedDef
validateEmbedded def = do
  let fields = thEmbeddedFields def
  assertUnique thExprName fields "expr field name in an embedded datatype"
  assertUnique thDbFieldName fields "db field name in an embedded datatype"
  mapM_ validateField fields
  return def

mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef
mkTHEntityDef NamingStyle{..} (DataD _ dName typeVars cons _) =
  THEntityDef dName (mkDbEntityName dName') Nothing (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) (Just $ apply mkDbConstrAutoKeyName) params [] where
      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
      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
      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
  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) Nothing (mkNormalExprSelectorName dName' cName' fNum) t 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
    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
  dName' = nameBase dName
mkTHPrimitiveDef _ _ = error "Only datatypes can be processed"

firstChar :: (Char -> Char) -> String -> String
firstChar f s = f (head s):tail s

-- | Transforms string from camelCase to lower_case_underscore naming convention.
-- ColumnName -> column_name, parseURL -> parse_url, FieldIEEE754Floating -> field_ieee754_floating
toUnderscore :: String -> String
toUnderscore = map toLower . go where
  go (x:y:z:xs) | isUpper x && isUpper y && isLower z = x:'_':y:go (z:xs)
  go (x:y:xs) | (isLower x || isDigit x) && isUpper y = x:'_':y:go xs
  go (x:xs) = x:go xs
  go "" = ""

-- $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.
--
-- @
--data Settable = First {foo :: String, bar :: Int, next :: Maybe (Key Settable BackendSpecific)} deriving (Eq, Show)
--
--    \-- The declaration with defaulted names
--
--mkPersist defaultCodegenConfig [groundhog|
--entity: Settable                       # If we did not have a constraint, this line would be enough
--keys:
--  - name: someconstraint
--constructors:
--  - name: First
--    uniques:
--      - name: someconstraint
--        fields: [foo, bar]
-- |]
-- @
--
-- Which is equivalent to the example below that has all properties set explicitly.
--
-- @
--mkPersist defaultCodegenConfig [groundhog|
--definitions:                           # First level key whose value is a list of definitions. It can be considered an optional header.
--                                       # The list elements start with hyphen+space. Keys are separated from values by a colon+space. See full definition at http://yaml.org/spec/1.2/spec.html.
--  - entity: Settable                   # Mandatory. Entity datatype name
--    dbName: Settable                   # Name of the main table
--    \# schema: public                   # Name of the schema to which the table belongs
--    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
--        keyDbName: id                  # Name for the primary key column
--        fields:                        # List of constructor fields. If you don't change a field, you can omit it
--          - name: foo                  # The name as in constructor record. If constructor is not a record, the name is created by 'mkNormalFieldName'. For example, the fields in constructor SomeConstr would have names someConstr0 and someConstr1 by default.
--            dbName: foo                # Column name
--            exprName: FooField         # Name of a field used in expressions
--          \# type: varchar              # This would result in having field type DbOther \"varchar\" instead of DbString. Value of this attribute will be used by DB backend for migration
--          \# default: foo_value         # The default value for column in the clause
--          \# reference:                 # This is explicit reference to a parent table not mapped by Groundhog
--          \#   schema: myschema         # Optional schema
--          \#   table: mytable           # Name of the parent table
--          \#   columns: [mytable_id]    # Parent columns. If the current field is embedded, e.g., a tuple, it will be a composite key
--          \#   onDelete: cascade        # Defines ON DELETE clause of references. It can have values: no action, restrict, cascade, set null, set default
--          \#   onUpdate: restrict       # Defines ON UPDATE
--          \# onDelete: cascade          # Clauses onDelete and onUpdate can be set outside of reference too. This is deprecated and kept for compatibility
--          \# If onDelete or onUpdate are omitted, the database will choose the action automatically. Note that it may differ across databases.
--          \# For example, MySQL has \"restrict\" by default, but in PostgreSQL it is \"no action\".
--          - name: bar
--            dbName: bar
--            exprName: BarField
--                                       # For some databases \"type: integer\" would be appropriate
--          - name: next
--            dbName: next
--            exprName: NextField
--        uniques:
--          - name: someconstraint
--            type: constraint           # The type can be be \"constraint\", \"index\", or \"primary\"
--            fields: [foo, bar]         # List of constructor parameter names. Not column names.
--   # This is example for databases which support expression indexes.
--   # Note that for checking index during migration expression should be written in exactly the same form as database returns.
--   #  - name: myuniqueindex
--   #    type: index
--   #    fields: [foo, {expr: "(bar + 1)" }]
-- |]
-- @
--
-- 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.
-- |]
-- @
--
-- We can also make our types instances of `PrimitivePersistField` to store them in one column.
--
-- @
--data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday
--  deriving (Eq, Show, Enum)
--data Point = Point Int Int
--  deriving (Eq, Show, Read)
--
--mkPersist defaultCodegenConfig [groundhog|
--definitions:
--  - primitive: WeekDay
--    representation: enum                # 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.
-- |]
-- @

-- | 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 defaultCodegenConfig [groundhogFile|../groundhog.yaml|]
groundhogFile :: QuasiQuoter
groundhogFile = quoteFile groundhog

parseDefinitions :: String -> Q Exp
parseDefinitions s = do
  result <- runIO $ decodeHelper (Y.decode $ encodeUtf8 $ fromString s)
  case result of
    Left err -> case err of
      InvalidYaml (Just (Y.YamlParseException problem context mark)) -> fail $ unlines
        [ "YAML parse error: " ++ problem
        , "Context: " ++ context
        , "At line: " ++ show (Y.yamlLine mark)
        , lines s !! Y.yamlLine mark
        , replicate (Y.yamlColumn mark) ' ' ++ "^"
        ]
      _ -> fail $ show err
    Right (Left err) -> fail err
    Right (Right result') -> lift (result' :: PersistDefinitions)

defaultMkEntityDecs :: [THEntityDef] -> Q [Dec]
defaultMkEntityDecs = fmap concat . mapM (\def -> do
  --runIO (print def)
  decs <- fmap concat $ sequence $ map ($ def)
    [ mkEntityPhantomConstructors
    , mkEntityPhantomConstructorInstances
    , mkAutoKeyPersistFieldInstance
    , mkAutoKeyPrimitivePersistFieldInstance
    , mkEntityUniqueKeysPhantoms
    , mkUniqueKeysIsUniqueInstances
    , mkUniqueKeysEmbeddedInstances
    , mkUniqueKeysPersistFieldInstances
    , mkUniqueKeysPrimitiveOrPurePersistFieldInstances
    , mkKeyEqShowInstances
    , mkEntityPersistFieldInstance
    , mkEntitySinglePersistFieldInstance
    , mkPersistEntityInstance
    , mkEntityNeverNullInstance
    ]
  --runIO $ putStrLn $ pprint decs
  return decs)

defaultMkEmbeddedDecs :: [THEmbeddedDef] -> Q [Dec]
defaultMkEmbeddedDecs = fmap concat . mapM (\def -> do
  --runIO (print def)
  decs <- fmap concat $ sequence $ map ($ def)
    [ mkEmbeddedPersistFieldInstance
    , mkEmbeddedPurePersistFieldInstance
    , mkEmbeddedInstance
    ]
--  runIO $ putStrLn $ pprint decs
  return decs)

defaultMkPrimitiveDecs :: [THPrimitiveDef] -> Q [Dec]
defaultMkPrimitiveDecs = fmap concat . mapM (\def -> do
  --runIO (print def)
  decs <- fmap concat $ sequence $ map ($ def)
    [ mkPrimitivePersistFieldInstance
    , mkPrimitivePrimitivePersistFieldInstance
    ]
--  runIO $ putStrLn $ pprint decs
  return decs)