content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  -- | 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,
  
      -- * Helpers
      showReadConverter,
      enumConverter,
    )
  where
  
  import Control.Applicative
  import Control.Monad (forM, forM_, liftM2, unless, when)
  import Data.Char (isDigit, isLower, isSpace, isUpper, toLower, toUpper)
  import Data.List (intercalate, nub, (\\))
  import Data.Maybe (fromMaybe, isJust, isNothing)
  import Data.String
  import Data.Text.Encoding (encodeUtf8)
  import Data.Yaml as Y (ParseException (..), decodeHelper)
  import Database.Groundhog.Core (UniqueType (..), delim)
  import Database.Groundhog.Generic
  import Database.Groundhog.TH.CodeGen
  import Database.Groundhog.TH.Settings
  import Language.Haskell.TH
  import Language.Haskell.TH.Quote
  import Language.Haskell.TH.Syntax (Lift (..), StrictType, VarStrictType)
  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
    checkEnabledLanguageExtensions
    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
          pure $ case info of
            TyConI d -> d
            _ -> 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,
        thFieldConverter = fmap mkName psFieldConverter
      }
  
  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,
        thPrimitiveConverter = mkName psPrimitiveConverter
      }
  
  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 :: (Eq b, Show b) => (a -> b) -> [a] -> String -> Either String ()
  assertUnique f xs what = case notUniqueBy f xs of
    [] -> pure ()
    ys -> Left $ "All " ++ what ++ " must be unique: " ++ show ys
  
  -- we need to validate datatype names because TH just creates unusable fields with spaces
  assertSpaceFree :: String -> String -> Either String ()
  assertSpaceFree s what = when (any isSpace s) $ Left $ "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
        [] -> pure ()
        ys -> Left $ "Constraints must have at least one field: " ++ show ys
      when (isNothing (thDbAutoKeyName cdef) /= isNothing (thAutoKey def)) $
        Left $ "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 Left $ "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) $
                Left $ "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) $
          Left $ "Custom primary keys may exist only for datatypes with single constructor: " ++ show (thDataName def)
      else
        when (primaryConstraints + maybe 0 (const 1) (thAutoKey def) > 1) $
          Left $ "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) $
      Left $ "A datatype with keys must have one default key: " ++ show (thDataName def)
    pure def
  
  validateField :: THFieldDef -> Either String ()
  validateField fDef = do
    assertSpaceFree (thExprName fDef) "field expr name"
    when (isJust (thDbTypeName fDef) && isJust (thEmbeddedDef fDef)) $
      Left $ "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
    pure def
  
  mkTHEntityDef :: NamingStyle -> Dec -> THEntityDef
  mkTHEntityDef NamingStyle {..} dec = THEntityDef dName (mkDbEntityName dName') Nothing autokey [] typeVars constrs
    where
      (dName, typeVars, cons) = fromDataD dec
      constrs = zipWith mkConstr [0 ..] cons
      dName' = nameBase dName
      autokey = Just $ THAutoKeyDef (mkEntityKeyName dName') True
  
      mkConstr cNum c = case c of
        NormalC name params -> mkConstr' name $ zipWith (mkField (nameBase name)) params [0 ..]
        RecC name params -> mkConstr' name $ zipWith (mkVarField (nameBase name)) params [0 ..]
        _ -> error $ "Only regular types and records are 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 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 Nothing
            where
              apply f = f dName' cName cNum fName' fNum
              fName' = nameBase fName
  
  mkTHEmbeddedDef :: NamingStyle -> Dec -> THEmbeddedDef
  mkTHEmbeddedDef NamingStyle {..} dec = THEmbeddedDef dName cName (mkDbEntityName dName') typeVars fields
    where
      (dName, typeVars, cons) = fromDataD dec
      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 ..])
          _ -> error $ "Only regular types and records are 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 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 Nothing
        where
          apply f = f dName' cName' 0 fName' fNum
          fName' = nameBase fName
  
  mkTHPrimitiveDef :: NamingStyle -> Dec -> THPrimitiveDef
  mkTHPrimitiveDef NamingStyle {..} dec = THPrimitiveDef dName (mkDbEntityName dName') 'showReadConverter
    where
      dName = case dec of
  #if MIN_VERSION_template_haskell(2, 11, 0)
        DataD _ name _ _ _ _ -> name
        NewtypeD _ name _ _ _ _ -> name
  #else
        DataD _ name _ _ _ -> name
        NewtypeD _ name _ _ _ -> name
  #endif
        _ -> error $ "Only datatypes and newtypes can be declared as primitive: " ++ show dec
      dName' = nameBase dName
  
  showReadConverter :: (Show a, Read a) => (a -> String, String -> a)
  showReadConverter = (show, read)
  
  enumConverter :: Enum a => (a -> Int, Int -> a)
  enumConverter = (fromEnum, toEnum)
  
  firstChar :: (Char -> Char) -> String -> String
  firstChar f s = f (head s) : tail s
  
  -- | 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
  --    converter: enumConverter            # Its column will have integer type. The conversion will use Enum instance.
  --  - primitive: Point
  --    converter: showReadConverter        # Its column will have string type. The conversion will use Show/Read instances. If representation is omitted, showread will be used by default.
  -- |]
  -- @
  
  -- | 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)
  
  checkEnabledLanguageExtensions :: Q ()
  checkEnabledLanguageExtensions = do
    exts <- extsEnabled
    let missingExtensions = map show (requiredLanguageExtensions \\ exts)
    unless (null missingExtensions) $
      fail $
        "Groundhog requires that you enable additionally the following language extensions: "
          ++ intercalate ", " missingExtensions
  
  requiredLanguageExtensions :: [Extension]
  requiredLanguageExtensions =
    [ GADTs,
      TypeFamilies,
      TemplateHaskell,
      QuasiQuotes,
      FlexibleInstances
    ]
  
  defaultMkEntityDecs :: [THEntityDef] -> Q [Dec]
  defaultMkEntityDecs =
    fmap concat
      . mapM
        ( \def ->
            concat
              <$> mapM
                ($ def)
                [ mkEntityPhantomConstructors,
                  mkEntityPhantomConstructorInstances,
                  mkAutoKeyPersistFieldInstance,
                  mkAutoKeyPrimitivePersistFieldInstance,
                  mkEntityUniqueKeysPhantoms,
                  mkUniqueKeysIsUniqueInstances,
                  mkUniqueKeysEmbeddedInstances,
                  mkUniqueKeysPersistFieldInstances,
                  mkUniqueKeysPrimitiveOrPurePersistFieldInstances,
                  mkKeyEqShowInstances,
                  mkEntityPersistFieldInstance,
                  mkEntitySinglePersistFieldInstance,
                  mkPersistEntityInstance,
                  mkEntityNeverNullInstance
                ]
        )
  
  defaultMkEmbeddedDecs :: [THEmbeddedDef] -> Q [Dec]
  defaultMkEmbeddedDecs =
    fmap concat
      . mapM
        ( \def ->
            concat
              <$> mapM
                ($ def)
                [ mkEmbeddedPersistFieldInstance,
                  mkEmbeddedPurePersistFieldInstance,
                  mkEmbeddedInstance
                ]
        )
  
  defaultMkPrimitiveDecs :: [THPrimitiveDef] -> Q [Dec]
  defaultMkPrimitiveDecs =
    fmap concat
      . mapM
        ( \def ->
            concat
              <$> mapM
                ($ def)
                [ mkPrimitivePersistFieldInstance,
                  mkPrimitivePrimitivePersistFieldInstance
                ]
        )
  
  #if MIN_VERSION_template_haskell(2, 17, 0)
  fromDataD :: InstanceDec -> (Name, [TyVarBndr ()], [Con])
  #else
  fromDataD :: InstanceDec -> (Name, [TyVarBndr], [Con])
  #endif
  fromDataD dec = case dec of
  #if MIN_VERSION_template_haskell(2, 11, 0)
    (DataD _ dName typeVars _ constrs _) -> (dName, typeVars, constrs)
  #else
    (DataD _ dName typeVars constrs _) -> (dName, typeVars, constrs)
  #endif
    _ -> error $ "Only datatypes can be processed: " ++ show dec
  