groundhog-th 0.11 → 0.12
raw patch · 4 files changed
+1674/−1511 lines, 4 filesdep ~aesondep ~groundhogPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson, groundhog
API changes (from Hackage documentation)
- Database.Groundhog.TH.Settings: instance Language.Haskell.TH.Syntax.Lift (Database.Groundhog.Generic.PSFieldDef GHC.Base.String)
+ Database.Groundhog.TH.Settings: instance Language.Haskell.TH.Syntax.Lift a => Language.Haskell.TH.Syntax.Lift (Database.Groundhog.Generic.PSFieldDef a)
Files
- Database/Groundhog/TH.hs +391/−320
- Database/Groundhog/TH/CodeGen.hs +923/−854
- Database/Groundhog/TH/Settings.hs +355/−334
- groundhog-th.cabal +5/−3
Database/Groundhog/TH.hs view
@@ -1,66 +1,71 @@-{-# LANGUAGE TemplateHaskell, RecordWildCards, CPP #-}+{-# 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+ ( -- * Settings format+ -- $settingsDoc+ mkPersist,+ groundhog,+ groundhogFile, -import Database.Groundhog.Core (delim, UniqueType(..))+ -- * 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.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 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]]-}+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]@@ -72,38 +77,38 @@ -- | 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-}+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. --@@ -120,23 +125,24 @@ -- > 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"-}+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. --@@ -153,12 +159,13 @@ -- > 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-}+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. --@@ -175,130 +182,147 @@ -- > 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-}+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-}+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+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- return $ case info of+ pure $ case info of TyConI d -> d- _ -> error $ "Only datatypes can be processed: " ++ name+ _ -> 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)+ 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+ 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}+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' = 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+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- }+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+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- }+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+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- }+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}+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- [] -> return ()+ [] -> pure () ys -> Left $ "All " ++ what ++ " must be unique: " ++ show ys -- we need to validate datatype names because TH just creates unusable fields with spaces@@ -317,7 +341,7 @@ assertUnique thDbFieldName fields "db field name in a constructor" mapM_ validateField fields case filter (\(THUniqueDef _ _ uFields) -> null uFields) $ thConstrUniques cdef of- [] -> return ()+ [] -> 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)@@ -326,23 +350,27 @@ 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 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+ 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)+ 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)- return def+ pure def validateField :: THFieldDef -> Either String () validateField fDef = do@@ -356,64 +384,71 @@ 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+ 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+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+ 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+ 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+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+ (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+ 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+mkTHPrimitiveDef NamingStyle {..} dec = THPrimitiveDef dName (mkDbEntityName dName') 'showReadConverter+ where+ dName = case dec of #if MIN_VERSION_template_haskell(2, 11, 0)- DataD _ dName _ _ _ _ -> dName- NewtypeD _ dName _ _ _ _ -> dName+ DataD _ name _ _ _ _ -> name+ NewtypeD _ name _ _ _ _ -> name #else- DataD _ dName _ _ _ -> dName- NewtypeD _ dName _ _ _ -> dName+ DataD _ name _ _ _ -> name+ NewtypeD _ name _ _ _ -> name #endif- _ -> error $ "Only datatypes and newtypes can be declared as primitive: " ++ show dec- dName' = nameBase dName+ _ -> 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)@@ -422,16 +457,17 @@ enumConverter = (fromEnum, toEnum) firstChar :: (Char -> Char) -> String -> String-firstChar f s = f (head s):tail s+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 "" = ""+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.@@ -444,15 +480,15 @@ -- 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)+-- 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:+-- mkPersist defaultCodegenConfig [groundhog|+-- entity: Settable # If we did not have a constraint, this line would be enough+-- keys: -- - name: someconstraint---constructors:+-- constructors: -- - name: First -- uniques: -- - name: someconstraint@@ -463,8 +499,8 @@ -- 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.+-- 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@@ -522,11 +558,11 @@ -- 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)+-- 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:+-- mkPersist defaultCodegenConfig [groundhog|+-- definitions: -- - entity: Company -- constructors: -- - name: Company@@ -557,13 +593,13 @@ -- We can also make our types instances of `PrimitivePersistField` to store them in one column. -- -- @---data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday+-- data WeekDay = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday -- deriving (Eq, Show, Enum)---data Point = Point Int Int+-- data Point = Point Int Int -- deriving (Eq, Show, Read) -----mkPersist defaultCodegenConfig [groundhog|---definitions:+-- mkPersist defaultCodegenConfig [groundhog|+-- definitions: -- - primitive: WeekDay -- converter: enumConverter # Its column will have integer type. The conversion will use Enum instance. -- - primitive: Point@@ -573,11 +609,13 @@ -- | 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"- }+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 --@@ -590,65 +628,98 @@ 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) ' ' ++ "^"- ]+ 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 -> 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)+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 -> do- --runIO (print def)- decs <- fmap concat $ sequence $ map ($ def)- [ mkEmbeddedPersistFieldInstance- , mkEmbeddedPurePersistFieldInstance- , mkEmbeddedInstance- ]--- runIO $ putStrLn $ pprint decs- return decs)+defaultMkEmbeddedDecs =+ fmap concat+ . mapM+ ( \def ->+ concat+ <$> mapM+ ($ def)+ [ mkEmbeddedPersistFieldInstance,+ mkEmbeddedPurePersistFieldInstance,+ mkEmbeddedInstance+ ]+ ) 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)+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])-fromDataD d = case d of+#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- d -> error $ "Only datatypes can be processed: " ++ show d+ _ -> error $ "Only datatypes can be processed: " ++ show dec
Database/Groundhog/TH/CodeGen.hs view
@@ -1,854 +1,923 @@-{-# LANGUAGE TemplateHaskell, RecordWildCards, DoAndIfThenElse, ExplicitForAll, StandaloneDeriving #-} -{-# LANGUAGE CPP #-} - -module Database.Groundhog.TH.CodeGen - ( mkEmbeddedPersistFieldInstance - , mkEmbeddedPurePersistFieldInstance - , mkEmbeddedInstance - , mkEntityPhantomConstructors - , mkEntityPhantomConstructorInstances - , mkEntityUniqueKeysPhantoms - , mkAutoKeyPersistFieldInstance - , mkAutoKeyPrimitivePersistFieldInstance - , mkUniqueKeysIsUniqueInstances - , mkUniqueKeysEmbeddedInstances - , mkUniqueKeysPersistFieldInstances - , mkUniqueKeysPrimitiveOrPurePersistFieldInstances - , mkKeyEqShowInstances - , mkEntityPersistFieldInstance - , mkEntitySinglePersistFieldInstance - , mkPersistEntityInstance - , mkEntityNeverNullInstance - , mkPrimitivePersistFieldInstance - , mkPrimitivePrimitivePersistFieldInstance - , 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.Applicative -import Control.Arrow (first) -import Control.Monad (liftM, liftM2, forM, forM_, filterM, replicateM, zipWithM) -import Data.Either (lefts, rights) -import Data.List (findIndex, nub, partition) -import Data.Maybe (catMaybes, mapMaybe) -import qualified GHC.Read as R -import qualified Text.Read.Lex as R -import qualified Text.ParserCombinators.ReadPrec as R - -mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec] -mkEmbeddedPersistFieldInstance def = do - let types = map extractType $ thEmbeddedTypeParams def - let embedded = foldl AppT (ConT (thEmbeddedName def)) types - - persistName' <- do - v <- newName "v" - let mkLambda t = [|undefined :: $(forallT (thEmbeddedTypeParams def) (cxt []) [t| $(return embedded) -> $(return t) |]) |] - let paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types - let fullEmbeddedName = case null types of - True -> [| $(stringE $ thDbEmbeddedName def) |] - False -> [| $(stringE $ thDbEmbeddedName def) ++ [delim] ++ $(paramNames) |] - let body = normalB $ fullEmbeddedName - let pat = if null types then wildP else varP v - funD 'persistName $ [ clause [pat] body [] ] - - toPersistValues' <- do - (pat, body) <- mkToPersistValues (thEmbeddedConstructorName def) (thEmbeddedFields def) id - funD 'toPersistValues [clause [pat] (normalB body) []] - - fromPersistValues' <- do - xs <- newName "xs" - failureName <- newName "failure" - (isFailureUsed, body) <- mkFromPersistValues failureName xs (thEmbeddedConstructorName def) (thEmbeddedFields def) - let failureBody = normalB [| (\a -> fail (failMessage a $(varE xs)) >> return (a, [])) undefined |] - failureFunc = funD failureName [clause [] failureBody []] - locals = if isFailureUsed then [failureFunc] else [] - funD 'fromPersistValues [clause [varP xs] (normalB $ return body) locals] - - dbType' <- do - v <- newName "v" - proxy <- newName "p" - let mkField fNum f = do - a <- newName "a" - let fname = thDbFieldName f - nvar = if hasFreeVars (thFieldType f) - then let pat = conP (thEmbeddedConstructorName def) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thEmbeddedFields def) - fNum - 1) wildP - in caseE (varE v) $ [match pat (normalB $ varE a) []] - else [| undefined :: $(return $ thFieldType f) |] - typ = mkType f proxy nvar - [| (fname, $typ) |] - let pat = if null $ thEmbeddedTypeParams def then wildP else varP v - funD 'dbType $ [ clause [varP proxy, pat] (normalB [| DbEmbedded (EmbeddedDef False $(listE $ zipWith mkField [0..] $ thEmbeddedFields def)) Nothing |]) [] ] - - let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def) - let decs = [persistName', toPersistValues', fromPersistValues', dbType'] - return $ [instanceD' context (AppT (ConT ''PersistField) embedded) decs] - -mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ) -mkToPersistValues constrName fieldDefs processResult = do - patVars <- mapM (const $ newName "x") fieldDefs - let processField fName fDef = do - isP <- isPrim (thFieldType fDef) - let field = maybe id (\convName x -> [| fst $(varE convName) $ $x |]) (thFieldConverter fDef) (varE fName) - if isP - then return (Nothing, [| (toPrimitivePersistValue $field:) |]) - else newName "x" >>= \x -> return (Just $ bindS (varP x) [| toPersistValues $field |], varE x) - (binds, funcs) <- liftM (first catMaybes . unzip) $ zipWithM processField patVars fieldDefs - let pat = conP constrName $ map varP patVars - result = [| return $ $(processResult $ if null funcs then [| id |] else foldr1 (\a b -> [|$a . $b|]) funcs) |] - body = if null binds then result else doE $ binds ++ [noBindS result] - return (pat, body) - -mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp) -mkFromPersistValues failureName values constrName fieldDefs = do - patVars <- mapM (const $ newName "x") fieldDefs - let failure = match wildP (normalB $ varE failureName) [] - mkArg (fName, fDef) = do - isP <- isPrim $ thFieldType fDef - let x = if isP - then [| fromPrimitivePersistValue $(varE fName) |] - else varE fName - maybe x (\convName -> [| snd $(varE convName) $ $x |]) $ thFieldConverter fDef - result = foldl (\func f -> appE func $ mkArg f) (conE constrName) $ zip patVars fieldDefs - goField xs vars = do - (fields, rest) <- spanM (liftM not . isPrim . thFieldType . snd) vars - xss <- liftM (xs:) $ mapM (const $ newName "xs") fields - let f oldXs newXs (fname, _) = bindS (conP '(,) [varP fname, varP newXs]) [| fromPersistValues $(varE oldXs) |] - stmts = zipWith3 f xss (tail xss) fields - expr = goPrim (last xss) rest - doE $ stmts ++ [noBindS expr] - goPrim xs vars = do - xs' <- newName "xs" - (prims, rest) <- spanM (isPrim . thFieldType . snd) vars - let body' = case rest of - [] -> [| return ($result, $(varE xs')) |] - _ -> goField xs' rest - m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') [] - if null prims - then caseE (varE xs) [m] - else caseE (varE xs) [m, failure] - body <- goPrim values $ zip patVars fieldDefs - anyPrim <- liftM or $ mapM (isPrim . thFieldType) fieldDefs - return (anyPrim, body) - -mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> Cxt -> Q [Dec] -mkPurePersistFieldInstance dataType cName fieldDefs context = do - toPurePersistValues' <- do - vars <- mapM (const $ newName "x") fieldDefs - let pat = conP cName $ map varP vars - body = mkToPurePersistValues $ zip vars fieldDefs - funD 'toPurePersistValues [clause [pat] (normalB body) []] - - fromPurePersistValues' <- let - goField xs vars result failure = do - (fields, rest) <- spanM (liftM not . isPrim . thFieldType . snd) vars - xss <- liftM (xs:) $ mapM (const $ newName "xs") fields - let f oldXs newXs (fName, _) = valD (conP '(,) [varP fName, varP newXs]) (normalB [| fromPurePersistValues $(varE oldXs) |]) [] - let stmts = zipWith3 f xss (tail xss) fields - (isFailureUsed, expr) <- goPrim (last xss) rest result failure - return (isFailureUsed, letE stmts expr) - goPrim xs vars result failure = do - xs' <- newName "xs" - (prims, rest) <- spanM (isPrim . thFieldType . snd) vars - (isFailureUsed, body') <- case rest of - [] -> return (False, [| ($result, $(varE xs')) |]) - _ -> goField xs' rest result failure - let m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') [] - return $ if null prims - then (isFailureUsed, caseE (varE xs) [m]) - else (True, caseE (varE xs) [m, failure]) - mkArg (fName, fDef) = do - isP <- isPrim $ thFieldType fDef - let x = if isP - then [| fromPrimitivePersistValue $(varE fName) |] - else varE fName - maybe x (\convName -> [| snd $(varE convName) $ $x |]) $ thFieldConverter fDef - in do - xs <- newName "xs" - let failureBody = normalB [| (\a -> error (failMessage a $(varE xs)) `asTypeOf` (a, [])) undefined |] - failureName <- newName "failure" - patVars <- mapM (const $ newName "x") fieldDefs - let failure = match wildP (normalB $ varE failureName) [] - result = foldl (\a f -> appE a $ mkArg f) (conE cName) $ zip patVars fieldDefs - (isFailureUsed, start) <- goPrim xs (zip patVars fieldDefs) result failure - let failureFunc = funD failureName [clause [] failureBody []] - locals = if isFailureUsed then [failureFunc] else [] - funD 'fromPurePersistValues [clause [varP xs] (normalB start) locals] - - let decs = [toPurePersistValues', fromPurePersistValues'] - return $ [instanceD' context (AppT (ConT ''PurePersistField) dataType) decs] - -mkEmbeddedPurePersistFieldInstance :: THEmbeddedDef -> Q [Dec] -mkEmbeddedPurePersistFieldInstance def = do - let types = map extractType $ thEmbeddedTypeParams def - let embedded = foldl AppT (ConT (thEmbeddedName def)) types - let fDefs = thEmbeddedFields def - context <- paramsPureContext (thEmbeddedTypeParams def) fDefs - case context of - Nothing -> return [] - Just context' -> mkPurePersistFieldInstance embedded (thEmbeddedConstructorName def) fDefs context' - -mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec] -mkAutoKeyPersistFieldInstance def = case thAutoKey def of - Just _ -> do - let entity = foldl AppT (ConT (thDataName 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 - proxy <- newName "p" - a <- newName "a" - let e = [| entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a)) |] - body = [| DbTypePrimitive (getDefaultAutoKeyType $(varE proxy)) False Nothing (Just (Left ($e, Nothing), Nothing, Nothing)) |] - funD 'dbType [clause [varP proxy, varP a] (normalB body) []] - - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [persistName', toPersistValues', fromPersistValues', dbType'] - return [instanceD' context (AppT (ConT ''PersistField) keyType) decs] - _ -> return [] - -mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec] -mkAutoKeyPrimitivePersistFieldInstance def = case thAutoKey def of - Just autoKey -> do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - keyType <- [t| Key $(return entity) BackendSpecific |] - let conName = mkName $ thAutoKeyConstrName autoKey - toPrim' <- do - x <- newName "x" - let body = [| $(varE x) |] - funD 'toPrimitivePersistValue [clause [conP conName [varP x]] (normalB body) []] - fromPrim' <- funD 'fromPrimitivePersistValue [clause [] (normalB $ conE conName) []] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [toPrim', fromPrim'] - sequence [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) keyType) decs - , mkDefaultPurePersistFieldInstance context keyType - , mkDefaultSinglePersistFieldInstance context keyType] - _ -> return [] - -mkDefaultPurePersistFieldInstance :: Cxt -> Type -> Q Dec -mkDefaultPurePersistFieldInstance context typ = do - toPurePersistValues' <- funD 'toPurePersistValues [clause [] (normalB [| primToPurePersistValues |]) []] - fromPurePersistValues' <- funD 'fromPurePersistValues [clause [] (normalB [| primFromPurePersistValues |]) []] - let decs = [toPurePersistValues', fromPurePersistValues'] - return $ instanceD' context (AppT (ConT ''PurePersistField) typ) decs - -mkDefaultSinglePersistFieldInstance :: Cxt -> Type -> Q Dec -mkDefaultSinglePersistFieldInstance context typ = do - toSinglePersistValue' <- funD 'toSinglePersistValue [clause [] (normalB [| primToSinglePersistValue |]) []] - fromSinglePersistValue' <- funD 'fromSinglePersistValue [clause [] (normalB [| primFromSinglePersistValue |]) []] - let decs = [toSinglePersistValue', fromSinglePersistValue'] - return $ instanceD' context (AppT (ConT ''SinglePersistField) typ) decs - -mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec] -mkUniqueKeysIsUniqueInstances def = do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - let constr = head $ thConstructors def - forM (thUniqueKeys def) $ \unique -> do - uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |] - extractUnique' <- do - uniqueFields <- mapM (\f -> newName "x" >>= \x -> return (thFieldName f, x)) $ thUniqueKeyFields unique - let mkFieldPat f = maybe wildP varP $ lookup (thFieldName f) uniqueFields - let pat = conP (thConstrName constr) $ map mkFieldPat $ thConstrFields constr - let body = foldl (\expr f -> [| $expr $(varE $ snd f) |]) (conE $ mkName $ thUniqueKeyConstrName unique) uniqueFields - funD 'extractUnique [clause [pat] (normalB body) []] - uniqueNum' <- do - let index = findIndex (\u -> thUniqueKeyName unique == thUniqueName u) $ thConstrUniques constr - let uNum = maybe (error $ "mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " ++ thUniqueKeyName unique) id index - funD 'uniqueNum [clause [wildP] (normalB [| uNum |]) []] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - return $ instanceD' context (AppT (ConT ''IsUniqueKey) uniqKeyType) [extractUnique', uniqueNum'] - -mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec] -mkUniqueKeysEmbeddedInstances def = do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - liftM concat $ forM (filter thUniqueKeyMakeEmbedded $ thUniqueKeys def) $ \unique -> do - uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - mkEmbeddedInstance' uniqKeyType (thUniqueKeyFields unique) context - -mkUniqueKeysPersistFieldInstances :: THEntityDef -> Q [Dec] -mkUniqueKeysPersistFieldInstances def = do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - forM (thUniqueKeys def) $ \unique -> do - uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |] - - 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" - proxy <- newName "p" - let mkField f = do - let fname = thDbFieldName f - nvar = [| undefined :: $(return $ thFieldType f) |] - typ = mkType f proxy nvar - [| (fname, $typ) |] - let embedded = [| EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique) |] - e = [| entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a)) |] - body = [| DbEmbedded $embedded (Just (Left ($e, Just $(lift $ thUniqueKeyName unique)), Nothing, Nothing)) |] - funD 'dbType [clause [varP proxy, varP a] (normalB body) []] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [persistName', toPersistValues', fromPersistValues', dbType'] - return $ instanceD' context (AppT (ConT ''PersistField) uniqKeyType) decs - -mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec] -mkUniqueKeysPrimitiveOrPurePersistFieldInstances def = do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - liftM concat $ forM (thUniqueKeys def) $ \unique -> do - uniqKeyType <- [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |] - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let conName = mkName $ thUniqueKeyConstrName unique - isUniquePrim <- case thUniqueKeyFields unique of - [uniq] -> isPrim $ thFieldType uniq - _ -> return False - if isUniquePrim - then do - x <- newName "x" - toPrim' <- do - funD 'toPrimitivePersistValue [clause [conP conName [varP x]] (normalB [| toPrimitivePersistValue $(varE x) |]) []] - fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP x] (normalB [| $(conE conName) (fromPrimitivePersistValue $(varE x)) |]) []] - let decs = [toPrim', fromPrim'] - sequence [ return $ instanceD' context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs - , mkDefaultPurePersistFieldInstance context uniqKeyType - , mkDefaultSinglePersistFieldInstance context uniqKeyType] - else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context - -mkKeyEqShowInstances :: THEntityDef -> Q [Dec] -mkKeyEqShowInstances def = do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - let keysInfo = maybe [] (\k -> [(thAutoKeyConstrName k, 1, [t| BackendSpecific |])]) (thAutoKey def) - ++ map (\k -> (thUniqueKeyConstrName k, length $ thUniqueKeyFields k, [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName k) |])) (thUniqueKeys def) - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - typ <- [t| Key $(return entity) $(newName "a" >>= varT) |] - - showsPrec' <- let - mkClause (cName, fieldsNum, _) = do - p <- newName "p" - fields <- replicateM fieldsNum (newName "x") - let pat = conP (mkName cName) $ map varP fields - showC = [| showString $(lift $ cName ++ " ") |] - showArgs = foldr1 (\a b -> [| $a . showString " " . $b |]) $ map (\a -> [| showsPrec 11 $(varE a) |]) fields - body = [| showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs) |] - clause [varP p, pat] (normalB body) [] - in funD 'showsPrec $ map mkClause keysInfo - - eq' <- let - mkClause (cName, fieldsNum, _) = do - let fields = replicateM fieldsNum (newName "x") - (fields1, fields2) <- liftM2 (,) fields fields - let mkPat = conP (mkName cName) . map varP - body = foldr1 (\e1 e2 -> [| $e1 && $e2 |]) $ zipWith (\n1 n2 -> [| $(varE n1) == $(varE n2) |]) fields1 fields2 - clause [mkPat fields1, mkPat fields2] (normalB body) [] - clauses = map mkClause keysInfo - noMatch = if length clauses > 1 then [clause [wildP, wildP] (normalB [| False |]) []] else [] - in funD '(==) $ clauses ++ noMatch - - read' <- let - mkRead (cName, fieldsNum, u) = do - let key = foldl (\a b -> [| $a <*> $b |]) [| $(conE $ mkName cName) <$> R.step R.readPrec |] - $ replicate (fieldsNum - 1) [| R.step R.readPrec |] - body = [| R.parens $ R.prec 10 $ R.expectP (R.Ident $(litE $ StringL cName)) >> $key |] - keyType <- [t| Key $(return entity) $u |] - readPrec' <- funD 'R.readPrec [clause [] (normalB body) []] - readListPrec' <- funD 'R.readListPrec [clause [] (normalB [| R.readListPrecDefault |]) []] - return $ instanceD' context (AppT (ConT ''Read) keyType) [readPrec', readListPrec'] - in mapM mkRead keysInfo - - return $ if null keysInfo - then [] - else [instanceD' context (AppT (ConT ''Eq) typ) [eq'], instanceD' context (AppT (ConT ''Show) typ) [showsPrec']] ++ read' - -mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec] -mkEmbeddedInstance def = do - let types = map extractType $ thEmbeddedTypeParams def - embedded = foldl AppT (ConT (thEmbeddedName def)) types - context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def) - mkEmbeddedInstance' embedded (thEmbeddedFields def) context - -mkEmbeddedInstance' :: Type -> [THFieldDef] -> Cxt -> Q [Dec] -mkEmbeddedInstance' dataType fDefs context = do - selector' <- do - fParam <- newName "f" - let mkField field = ForallC [] ([equalP' (VarT fParam) (thFieldType field)]) $ NormalC (mkName $ thExprName field) [] - return $ dataInstD' [] ''Selector [dataType, VarT fParam] (map mkField fDefs) [] - - selectorNum' <- do - let mkClause fNum field = clause [conP (mkName $ thExprName field) []] (normalB $ lift fNum) [] - 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 (thDataName 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 [] - return $ dataD' [] name [PlainTV v] [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)) [phantomConstrNum'] where - phantomConstrNum' = funD 'phantomConstrNum [clause [wildP] (normalB $ [| cNum |]) []] - -mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec] -mkEntityUniqueKeysPhantoms def = do - let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def - fmap concat $ forM (thUniqueKeys def) $ \u -> do - exists <- lookupTypeName $ thUniqueKeyPhantomName u - if exists == Nothing - then 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 [] - return [dataD' [] name [PlainTV v] [constr] []] - else return [] - -mkPersistEntityInstance :: THEntityDef -> Q [Dec] -mkPersistEntityInstance def = do - let entity = foldl AppT (ConT (thDataName 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 - uniqType <- [t| Unique $(conT $ mkName $ thUniqueKeyPhantomName unique) |] - let cDef = head $ thConstructors def - uniqFieldNames = lefts $ thUniqueFields $ findOne "unique" thUniqueName (thUniqueKeyName unique) $ thConstrUniques cDef - uniqFields = concat $ flip map uniqFieldNames $ \name -> (filter ((== name) . thFieldName) $ thConstrFields cDef) - uniqFields' = map (\f -> (notStrict', thFieldType f)) uniqFields - 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 -> [t| () |] - Just _ -> [t| Key $(return entity) BackendSpecific |] - return $ mkTySynInstD ''AutoKey [entity] autoType - - defaultKey' <- do - typ <- case thAutoKey def of - Just k | thAutoKeyIsDef k -> [t| Key $(return entity) BackendSpecific |] - _ -> case filter thUniqueKeyIsDef $ thUniqueKeys def of - [unique] -> [t| Key $(return entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)) |] - _ -> [t| () |] - return $ mkTySynInstD ''DefaultKey [entity] typ - - isSumType' <- do - let isSumType = ConT $ if length (thConstructors def) == 1 - then ''HFalse - else ''HTrue - return $ mkTySynInstD ''IsSumType [entity] isSumType - - fields' <- do - cParam <- newName "c" - fParam <- newName "f" - let mkField name field = ForallC [] [equalP' (VarT cParam) (ConT name), equalP' (VarT fParam) (thFieldType field)] $ NormalC (mkName $ thExprName field) [] - let f cdef = map (mkField $ mkName $ thPhantomConstrName cdef) $ thConstrFields cdef - let constrs = concatMap f $ thConstructors def - return $ dataInstD' [] ''Field [entity, VarT cParam, VarT fParam] constrs [] - - entityDef' <- do - v <- newName "v" - proxy <- newName "p" - let mkLambda t = [|undefined :: $(forallT (thTypeParams def) (cxt []) [t| $(return entity) -> $(return t) |]) |] - types = map extractType $ thTypeParams def - typeParams' = listE $ map (\t -> [| dbType $(varE proxy) ($(mkLambda t) $(varE v)) |]) types - mkField c fNum f = do - a <- newName "a" - let fname = thDbFieldName f - nvar = if hasFreeVars (thFieldType f) - then let pat = conP (thConstrName c) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thConstrFields c) - fNum - 1) wildP - wildClause = if length (thConstructors def) > 1 then [match wildP (normalB [| undefined |]) []] else [] - in caseE (varE v) $ [match pat (normalB $ varE a) []] ++ wildClause - else [| undefined :: $(return $ thFieldType f) |] - typ = mkType f proxy nvar - [| (fname, $typ) |] - constrs = listE $ map mkConstructorDef $ thConstructors def - mkConstructorDef c@(THConstructorDef _ _ name keyName params conss) = [| ConstructorDef name keyName $(listE $ map snd fields) $(listE $ map mkConstraint conss) |] where - fields = zipWith (\i f -> (thFieldName f, mkField c i f)) [0..] params - mkConstraint (THUniqueDef uName uType uFields) = [| UniqueDef (Just uName) uType $(listE $ map getField uFields) |] - getField (Left fName) = [| Left $(snd $ findOne "field" fst fName fields) |] - getField (Right expr) = [| Right expr |] - - paramNames = foldr1 (\p xs -> [| $p ++ [delim] ++ $xs |] ) $ map (\t -> [| persistName ($(mkLambda t) $(varE v)) |]) types - fullEntityName = case null types of - True -> [| $(stringE $ thDbEntityName def) |] - False -> [| $(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames) |] - - body = normalB [| EntityDef $fullEntityName $(lift $ thEntitySchema def) $typeParams' $constrs |] - entityPat = if null $ thTypeParams def then wildP else varP v - funD 'entityDef $ [ clause [varP proxy, entityPat] body [] ] - - toEntityPersistValues' <- liftM (FunD 'toEntityPersistValues) $ forM (zip [0 :: Int ..] $ thConstructors def) $ \(cNum, c) -> do - (pat, body) <- mkToPersistValues (thConstrName c) (thConstrFields c) (\result -> [| (toPrimitivePersistValue ($(lift cNum) :: Int) :) . $result |]) - clause [pat] (normalB body) [] - - fromEntityPersistValues' <- do - xs <- newName "xs" - let failureBody = normalB [| fail (failMessageNamed $(stringE $ show $ thDataName def) $(varE xs)) |] - failureName <- newName "failure" - let failure = match wildP (normalB $ varE failureName) [] - matches <- forM (zip [0..] (thConstructors def)) $ \(cNum, c) -> do - 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]] - - getUniques' <- let - hasConstraints = not . null . thConstrUniques - clauses = zipWith mkClause [0::Int ..] (thConstructors def) - mkClause cNum cdef | not (hasConstraints cdef) = clause [conP (thConstrName cdef) pats] (normalB [| (cNum, []) |]) [] where - pats = map (const wildP) $ thConstrFields cdef - mkClause cNum cdef = do - let allConstrainedFields = lefts $ concatMap thUniqueFields $ thConstrUniques cdef - vars <- mapM (\f -> newName "x" >>= \x -> return $ if thFieldName f `elem` allConstrainedFields then Just (x, f) else Nothing) $ thConstrFields cdef - let pat = conP (thConstrName cdef) $ map (maybe wildP (varP . fst)) vars - body = normalB $ [| (cNum, $(listE $ mapMaybe mkUnique $ thConstrUniques cdef)) |] - mkUnique (THUniqueDef uName _ fnames) = if null $ rights fnames - then let - -- find corresponding field from vars - uFields = map (\f -> findOne "field" (thFieldName . snd) f $ catMaybes vars) $ lefts fnames - result = mkToPurePersistValues uFields - in Just [| (uName, $result) |] - else Nothing - clause [pat] body [] - in funD 'getUniques clauses - - entityFieldChain' <- let - thFieldNames = thConstructors def >>= thConstrFields - clauses = map mkClause thFieldNames - mkClause f = do - fArg <- newName "f" - proxy <- newName "p" - let nvar = [| (undefined :: Field v c a -> a) $(varE fArg) |] - typ = mkType f proxy nvar - body = [| (($(lift $ thDbFieldName f), $typ), []) |] - clause [varP proxy, asP fArg $ conP (mkName $ thExprName f) []] (normalB body) [] - clauses' = if null clauses then [clause [wildP] (normalB [| undefined |]) []] else clauses - in funD 'entityFieldChain clauses' - - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [key', autoKey', defaultKey', isSumType', fields', entityDef', toEntityPersistValues', fromEntityPersistValues', getUniques', entityFieldChain'] - return $ [instanceD' context (AppT (ConT ''PersistEntity) entity) decs] - -mkToPurePersistValues :: [(Name, THFieldDef)] -> Q Exp -mkToPurePersistValues vars = do - let processField (fName, fDef) = do - isP <- isPrim (thFieldType fDef) - let field = maybe id (\convName x -> [| fst $(varE convName) $ $x |]) (thFieldConverter fDef) (varE fName) - if isP - then return (Nothing, [| (toPrimitivePersistValue $field:) |]) - else newName "x" >>= \x -> return (Just $ valD (varP x) (normalB [| toPurePersistValues $(varE fName) |]) [], varE x) - (lets, funcs) <- liftM (first catMaybes . unzip) $ mapM processField vars - let result = if null funcs then [| id |] else foldr1 (\a b -> [|$a . $b|]) funcs - if null lets then result else letE lets result - -mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec] -mkEntityPersistFieldInstance def = case getDefaultKey def of - Just defaultKey -> do - let types = map extractType $ thTypeParams def - let entity = foldl AppT (ConT (thDataName 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 $ thDbEntityName def) |] - False -> [| $(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames) |] - let body = normalB $ fullEntityName - let pat = if null types then wildP else varP v - funD 'persistName $ [ clause [pat] body [] ] - - isOne <- isDefaultKeyOneColumn def - let uniqInfo = either auto uniq defaultKey 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 [] ] - - fromPersistValues' <- 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 - proxy <- newName "p" - let body = [| dbType $(varE proxy) . (undefined :: a -> DefaultKey a) |] - funD 'dbType $ [clause [varP proxy] (normalB body) []] - - let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - let decs = [persistName', toPersistValues', fromPersistValues', dbType'] - return $ [instanceD' context (AppT (ConT ''PersistField) entity) decs] - Nothing -> return [] - -mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec] -mkEntitySinglePersistFieldInstance def = isDefaultKeyOneColumn def >>= \isOne -> case getDefaultKey def of - Just defaultKey | isOne -> do - let types = map extractType $ thTypeParams def - entity = foldl AppT (ConT (thDataName def)) types - context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - - (to, from) = case defaultKey of - Left _ -> ([| toSinglePersistValueAutoKey |], [| fromSinglePersistValueAutoKey |]) - Right k -> ([| toSinglePersistValueUnique $u |], [| fromSinglePersistValueUnique $u |]) where - u = conE $ mkName $ thUniqueKeyPhantomName k - - toSinglePersistValue' <- funD 'toSinglePersistValue $ [ clause [] (normalB to) [] ] - fromSinglePersistValue' <- funD 'fromSinglePersistValue $ [ clause [] (normalB from) []] - let decs = [toSinglePersistValue', fromSinglePersistValue'] - return [instanceD' context (AppT (ConT ''SinglePersistField) entity) decs] - _ -> return [] - -mkEntityNeverNullInstance :: THEntityDef -> Q [Dec] -mkEntityNeverNullInstance def = do - let types = map extractType $ thTypeParams def - entity = foldl AppT (ConT (thDataName def)) types - context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields) - isOne <- isDefaultKeyOneColumn def - return $ if isOne - then [instanceD' context (AppT (ConT ''NeverNull) entity) []] - else [] - -mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec] -mkPrimitivePersistFieldInstance def = do - let primitive = ConT (thPrimitiveName def) - persistName' <- do - let body = normalB $ stringE $ nameBase $ thPrimitiveName def - funD 'persistName $ [ clause [wildP] body [] ] - fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [| primFromPersistValue |]) []] - toPersistValues' <- funD 'toPersistValues [clause [] (normalB [| primToPersistValue |]) []] - dbType' <- do - proxy <- newName "p" - x <- newName "x" - let body = [| dbType $(varE proxy) $ fst $(varE $ thPrimitiveConverter def) $ $(varE x) |] - funD 'dbType $ [ clause [varP proxy, varP x] (normalB body) [] ] - let decs = [persistName', toPersistValues', fromPersistValues', dbType'] - return [ instanceD' [] (AppT (ConT ''PersistField) primitive) decs - , instanceD' [] (AppT (ConT ''NeverNull) primitive) [] - ] - -mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec] -mkPrimitivePrimitivePersistFieldInstance def = do - let primitive = ConT (thPrimitiveName def) - toPrim' <- do - let body = [| toPrimitivePersistValue . fst $(varE $ thPrimitiveConverter def) |] - funD 'toPrimitivePersistValue [clause [] (normalB body) []] - fromPrim' <- do - let body = [| snd $(varE $ thPrimitiveConverter def) . fromPrimitivePersistValue |] - funD 'fromPrimitivePersistValue [clause [] (normalB body) []] - let context = [] - let decs = [toPrim', fromPrim'] - sequence $ [return $ instanceD' context (AppT (ConT ''PrimitivePersistField) primitive) decs - , mkDefaultPurePersistFieldInstance context primitive - , mkDefaultSinglePersistFieldInstance context primitive] - -mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec] -mkMigrateFunction name defs = do - let (normal, polymorhpic) = partition (null . thTypeParams) defs - forM_ polymorhpic $ \def -> reportWarning $ "Datatype " ++ show (thDataName def) ++ " will not be migrated automatically by function " ++ name ++ " because it has type parameters" - let body = doE $ map (\def -> noBindS [| migrate (undefined :: $(conT $ thDataName def)) |]) normal - sig <- sigD (mkName name) [t| forall m . PersistBackend m => Migration m |] - func <- funD (mkName name) [clause [] (normalB body) []] - return [sig, func] - -isDefaultKeyOneColumn :: THEntityDef -> Q Bool -isDefaultKeyOneColumn def = case getDefaultKey def of - Just (Left _) -> return True - Just (Right unique) | (length $ thUniqueKeyFields unique) == 1 -> - isPrim $ thFieldType $ head $ thUniqueKeyFields unique - _ -> return False - -getDefaultKey :: THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef) -getDefaultKey def = case thAutoKey def of - Just k | thAutoKeyIsDef k -> Just $ Left k - _ -> case filter thUniqueKeyIsDef $ thUniqueKeys def of - [] -> Nothing - (u:_) -> Just $ Right u - -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 . thFieldType - -paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe Cxt) -paramsPureContext types fields = do - let isValidType (VarT _) = return True - isValidType t = isPrim t - invalid <- filterM (liftM not . isValidType . thFieldType) 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 . thFieldType - _ -> 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 - -#if !MIN_VERSION_template_haskell(2, 8, 0) -reportWarning :: String -> Q () -reportWarning = report False -#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) - -mkType :: THFieldDef -> Name -> ExpQ -> ExpQ -mkType THFieldDef{..} proxy nvar = t3 where - psField = PSFieldDef thFieldName (Just thDbFieldName) thDbTypeName (Just thExprName) thEmbeddedDef thDefaultValue thReferenceParent (fmap show thFieldConverter) - t1 = maybe id (\convName x -> [| fst $(varE convName) $ $x |]) thFieldConverter nvar - t2 = [| dbType $(varE proxy) $t1 |] - -- if there are any type settings, apply them in runtime - t3 = case (thDbTypeName, thEmbeddedDef, thDefaultValue, thReferenceParent) of - (Nothing, Nothing, Nothing, Nothing) -> t2 - _ -> [| applyDbTypeSettings $(lift psField) $t2 |] - -mkTySynInstD :: Name -> [Type] -> Type -> Dec -mkTySynInstD name ts t = -#if MIN_VERSION_template_haskell(2, 15, 0) - TySynInstD $ TySynEqn Nothing typ t where - typ = foldl AppT (ConT name) ts -#elif MIN_VERSION_template_haskell(2, 9, 0) - TySynInstD name $ TySynEqn ts t -#else - TySynInstD name ts t -#endif - -classP' :: Name -> [Type] -> Pred -classP' name ts = -#if MIN_VERSION_template_haskell(2, 10, 0) - foldl AppT (ConT name) ts -#else - ClassP name ts -#endif - -equalP' :: Type -> Type -> Pred -equalP' t1 t2 = -#if MIN_VERSION_template_haskell(2, 10, 0) - foldl AppT EqualityT [t1, t2] -#else - EqualP t1 t2 -#endif - -instanceD' :: Cxt -> Type -> [Dec] -> InstanceDec -instanceD' = -#if MIN_VERSION_template_haskell(2, 11, 0) - InstanceD Nothing -#else - InstanceD -#endif - -dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec -dataInstD' cxt name types constrs derives = -#if MIN_VERSION_template_haskell(2, 15, 0) - DataInstD cxt Nothing typ Nothing constrs [DerivClause Nothing (map ConT derives)] where - typ = foldl AppT (ConT name) types -#elif MIN_VERSION_template_haskell(2, 12, 0) - DataInstD cxt name types Nothing constrs [DerivClause Nothing (map ConT derives)] -#elif MIN_VERSION_template_haskell(2, 11, 0) - DataInstD cxt name types Nothing constrs (map ConT derives) -#else - DataInstD cxt name types constrs derives -#endif - -dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec -dataD' cxt name types constrs derives = -#if MIN_VERSION_template_haskell(2, 12, 0) - DataD cxt name types Nothing constrs [DerivClause Nothing (map ConT derives)] -#elif MIN_VERSION_template_haskell(2, 11, 0) - DataD cxt name types Nothing constrs (map ConT derives) -#else - DataD cxt name types constrs derives -#endif - -#if MIN_VERSION_template_haskell(2, 11, 0) -notStrict' :: Bang -notStrict' = Bang NoSourceUnpackedness NoSourceStrictness -#else -notStrict' :: Strict -notStrict' = NotStrict -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.Groundhog.TH.CodeGen+ ( mkEmbeddedPersistFieldInstance,+ mkEmbeddedPurePersistFieldInstance,+ mkEmbeddedInstance,+ mkEntityPhantomConstructors,+ mkEntityPhantomConstructorInstances,+ mkEntityUniqueKeysPhantoms,+ mkAutoKeyPersistFieldInstance,+ mkAutoKeyPrimitivePersistFieldInstance,+ mkUniqueKeysIsUniqueInstances,+ mkUniqueKeysEmbeddedInstances,+ mkUniqueKeysPersistFieldInstances,+ mkUniqueKeysPrimitiveOrPurePersistFieldInstances,+ mkKeyEqShowInstances,+ mkEntityPersistFieldInstance,+ mkEntitySinglePersistFieldInstance,+ mkPersistEntityInstance,+ mkEntityNeverNullInstance,+ mkPrimitivePersistFieldInstance,+ mkPrimitivePrimitivePersistFieldInstance,+ mkMigrateFunction,+ )+where++import Control.Arrow (first)+import Control.Monad (filterM, forM, forM_, liftM2, replicateM, zipWithM)+import Data.Either (lefts, rights)+import Data.List (findIndex, nub, partition)+import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe)+import Database.Groundhog.Core+import Database.Groundhog.Generic+import Database.Groundhog.TH.Settings+import qualified GHC.Read as R+import Language.Haskell.TH hiding (TyVarBndr)+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (Lift (..))+import qualified Text.ParserCombinators.ReadPrec as R+import qualified Text.Read.Lex as R++mkEmbeddedPersistFieldInstance :: THEmbeddedDef -> Q [Dec]+mkEmbeddedPersistFieldInstance def = do+ let types = map extractType $ thEmbeddedTypeParams def+ let embedded = foldl AppT (ConT (thEmbeddedName def)) types++ persistName' <- do+ v <- newName "v"+ let mkLambda t = [|undefined :: $(pure embedded) -> $(pure t)|]+ let paramNames = foldr1 (\p xs -> [|$p ++ [delim] ++ $xs|]) $ map (\t -> [|persistName ($(mkLambda t) $(varE v))|]) types+ let fullEmbeddedName =+ if null types+ then [|$(stringE $ thDbEmbeddedName def)|]+ else [|$(stringE $ thDbEmbeddedName def) ++ [delim] ++ $(paramNames)|]+ let body = normalB fullEmbeddedName+ let pat = if null types then wildP else varP v+ funD 'persistName [clause [pat] body []]++ toPersistValues' <- do+ (pat, body) <- mkToPersistValues (thEmbeddedConstructorName def) (thEmbeddedFields def) id+ funD 'toPersistValues [clause [pat] (normalB body) []]++ fromPersistValues' <- do+ xs <- newName "xs"+ failureName <- newName "failure"+ (isFailureUsed, body) <- mkFromPersistValues failureName xs (thEmbeddedConstructorName def) (thEmbeddedFields def)+ let failureBody = normalB [|(\a -> fail (failMessage a $(varE xs)) >> pure (a, [])) undefined|]+ failureFunc = funD failureName [clause [] failureBody []]+ locals = if isFailureUsed then [failureFunc] else []+ funD 'fromPersistValues [clause [varP xs] (normalB $ pure body) locals]++ dbType' <- do+ v <- newName "v"+ proxy <- newName "p"+ let mkField fNum f = do+ a <- newName "a"+ let fname = thDbFieldName f+ nvar =+ if hasFreeVars (thFieldType f)+ then+ let pat = conP (thEmbeddedConstructorName def) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thEmbeddedFields def) - fNum - 1) wildP+ in caseE (varE v) [match pat (normalB $ varE a) []]+ else [|undefined :: $(pure $ thFieldType f)|]+ typ = mkType f proxy nvar+ [|(fname, $typ)|]+ let pat = if null $ thEmbeddedTypeParams def then wildP else varP v+ funD 'dbType [clause [varP proxy, pat] (normalB [|DbEmbedded (EmbeddedDef False $(listE $ zipWith mkField [0 ..] $ thEmbeddedFields def)) Nothing|]) []]++ let context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)+ let decs = [persistName', toPersistValues', fromPersistValues', dbType']+ pure [instanceD' context (AppT (ConT ''PersistField) embedded) decs]++mkToPersistValues :: Name -> [THFieldDef] -> (ExpQ -> ExpQ) -> Q (PatQ, ExpQ)+mkToPersistValues constrName fieldDefs processResult = do+ patVars <- mapM (const $ newName "x") fieldDefs+ let processField fName fDef = do+ isP <- isPrim (thFieldType fDef)+ let field = maybe id (\convName x -> [|fst $(varE convName) $ $x|]) (thFieldConverter fDef) (varE fName)+ if isP+ then pure (Nothing, [|(toPrimitivePersistValue $field :)|])+ else newName "x" >>= \x -> pure (Just $ bindS (varP x) [|toPersistValues $field|], varE x)+ (binds, funcs) <- first catMaybes . unzip <$> zipWithM processField patVars fieldDefs+ let pat = conP constrName $ map varP patVars+ result = [|pure $(processResult $ if null funcs then [|id|] else foldr1 (\a b -> [|$a . $b|]) funcs)|]+ body = if null binds then result else doE $ binds ++ [noBindS result]+ pure (pat, body)++mkFromPersistValues :: Name -> Name -> Name -> [THFieldDef] -> Q (Bool, Exp)+mkFromPersistValues failureName values constrName fieldDefs = do+ patVars <- mapM (const $ newName "x") fieldDefs+ let failure = match wildP (normalB $ varE failureName) []+ mkArg (fName, fDef) = do+ isP <- isPrim $ thFieldType fDef+ let x =+ if isP+ then [|fromPrimitivePersistValue $(varE fName)|]+ else varE fName+ maybe x (\convName -> [|snd $(varE convName) $ $x|]) $ thFieldConverter fDef+ result = foldl (\func f -> appE func $ mkArg f) (conE constrName) $ zip patVars fieldDefs+ goField xs vars = do+ (fields, rest) <- spanM (fmap not . isPrim . thFieldType . snd) vars+ xss <- (xs :) <$> mapM (const $ newName "xs") fields+ let f oldXs newXs (fname, _) = bindS (conP '(,) [varP fname, varP newXs]) [|fromPersistValues $(varE oldXs)|]+ stmts = zipWith3 f xss (tail xss) fields+ expr = goPrim (last xss) rest+ doE $ stmts ++ [noBindS expr]+ goPrim xs vars = do+ xs' <- newName "xs"+ (prims, rest) <- spanM (isPrim . thFieldType . snd) vars+ let body' = case rest of+ [] -> [|pure ($result, $(varE xs'))|]+ _ -> goField xs' rest+ m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') []+ if null prims+ then caseE (varE xs) [m]+ else caseE (varE xs) [m, failure]+ body <- goPrim values $ zip patVars fieldDefs+ anyPrim <- or <$> mapM (isPrim . thFieldType) fieldDefs+ pure (anyPrim, body)++mkPurePersistFieldInstance :: Type -> Name -> [THFieldDef] -> Cxt -> Q [Dec]+mkPurePersistFieldInstance dataType cName fieldDefs context = do+ toPurePersistValues' <- do+ vars <- mapM (const $ newName "x") fieldDefs+ let pat = conP cName $ map varP vars+ body = mkToPurePersistValues $ zip vars fieldDefs+ funD 'toPurePersistValues [clause [pat] (normalB body) []]++ fromPurePersistValues' <-+ let goField xs vars result failure = do+ (fields, rest) <- spanM (fmap not . isPrim . thFieldType . snd) vars+ xss <- (xs :) <$> mapM (const $ newName "xs") fields+ let f oldXs newXs (fName, _) = valD (conP '(,) [varP fName, varP newXs]) (normalB [|fromPurePersistValues $(varE oldXs)|]) []+ let stmts = zipWith3 f xss (tail xss) fields+ (isFailureUsed, expr) <- goPrim (last xss) rest result failure+ pure (isFailureUsed, letE stmts expr)+ goPrim xs vars result failure = do+ xs' <- newName "xs"+ (prims, rest) <- spanM (isPrim . thFieldType . snd) vars+ (isFailureUsed, body') <- case rest of+ [] -> pure (False, [|($result, $(varE xs'))|])+ _ -> goField xs' rest result failure+ let m = match (foldr (\(fName, _) p -> infixP (varP fName) '(:) p) (varP xs') prims) (normalB body') []+ pure $+ if null prims+ then (isFailureUsed, caseE (varE xs) [m])+ else (True, caseE (varE xs) [m, failure])+ mkArg (fName, fDef) = do+ isP <- isPrim $ thFieldType fDef+ let x =+ if isP+ then [|fromPrimitivePersistValue $(varE fName)|]+ else varE fName+ maybe x (\convName -> [|snd $(varE convName) $ $x|]) $ thFieldConverter fDef+ in do+ xs <- newName "xs"+ let failureBody = normalB [|(\a -> error (failMessage a $(varE xs)) `asTypeOf` (a, [])) undefined|]+ failureName <- newName "failure"+ patVars <- mapM (const $ newName "x") fieldDefs+ let failure = match wildP (normalB $ varE failureName) []+ result = foldl (\a f -> appE a $ mkArg f) (conE cName) $ zip patVars fieldDefs+ (isFailureUsed, start) <- goPrim xs (zip patVars fieldDefs) result failure+ let failureFunc = funD failureName [clause [] failureBody []]+ locals = if isFailureUsed then [failureFunc] else []+ funD 'fromPurePersistValues [clause [varP xs] (normalB start) locals]++ let decs = [toPurePersistValues', fromPurePersistValues']+ pure [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 (thEmbeddedName def)) types+ let fDefs = thEmbeddedFields def+ context <- paramsPureContext (thEmbeddedTypeParams def) fDefs+ case context of+ Nothing -> pure []+ Just context' -> mkPurePersistFieldInstance embedded (thEmbeddedConstructorName def) fDefs context'++mkAutoKeyPersistFieldInstance :: THEntityDef -> Q [Dec]+mkAutoKeyPersistFieldInstance def = case thAutoKey def of+ Just _ -> do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ keyType <- [t|Key $(pure 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+ proxy <- newName "p"+ a <- newName "a"+ let e = [|entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a))|]+ body = [|DbTypePrimitive (getDefaultAutoKeyType $(varE proxy)) False Nothing (Just (Left ($e, Nothing), Nothing, Nothing))|]+ funD 'dbType [clause [varP proxy, varP a] (normalB body) []]++ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ let decs = [persistName', toPersistValues', fromPersistValues', dbType']+ pure [instanceD' context (AppT (ConT ''PersistField) keyType) decs]+ _ -> pure []++mkAutoKeyPrimitivePersistFieldInstance :: THEntityDef -> Q [Dec]+mkAutoKeyPrimitivePersistFieldInstance def = case thAutoKey def of+ Just autoKey -> do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ keyType <- [t|Key $(pure entity) BackendSpecific|]+ let conName = mkName $ thAutoKeyConstrName autoKey+ toPrim' <- do+ x <- newName "x"+ let body = [|$(varE x)|]+ funD 'toPrimitivePersistValue [clause [conP conName [varP x]] (normalB body) []]+ fromPrim' <- funD 'fromPrimitivePersistValue [clause [] (normalB $ conE conName) []]+ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ let decs = [toPrim', fromPrim']+ sequence+ [ pure $ instanceD' context (AppT (ConT ''PrimitivePersistField) keyType) decs,+ mkDefaultPurePersistFieldInstance context keyType,+ mkDefaultSinglePersistFieldInstance context keyType+ ]+ _ -> pure []++mkDefaultPurePersistFieldInstance :: Cxt -> Type -> Q Dec+mkDefaultPurePersistFieldInstance context typ = do+ toPurePersistValues' <- funD 'toPurePersistValues [clause [] (normalB [|primToPurePersistValues|]) []]+ fromPurePersistValues' <- funD 'fromPurePersistValues [clause [] (normalB [|primFromPurePersistValues|]) []]+ let decs = [toPurePersistValues', fromPurePersistValues']+ pure $ instanceD' context (AppT (ConT ''PurePersistField) typ) decs++mkDefaultSinglePersistFieldInstance :: Cxt -> Type -> Q Dec+mkDefaultSinglePersistFieldInstance context typ = do+ toSinglePersistValue' <- funD 'toSinglePersistValue [clause [] (normalB [|primToSinglePersistValue|]) []]+ fromSinglePersistValue' <- funD 'fromSinglePersistValue [clause [] (normalB [|primFromSinglePersistValue|]) []]+ let decs = [toSinglePersistValue', fromSinglePersistValue']+ pure $ instanceD' context (AppT (ConT ''SinglePersistField) typ) decs++mkUniqueKeysIsUniqueInstances :: THEntityDef -> Q [Dec]+mkUniqueKeysIsUniqueInstances def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ let constr = head $ thConstructors def+ forM (thUniqueKeys def) $ \unique -> do+ uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]+ extractUnique' <- do+ uniqueFields <- mapM (\f -> newName "x" >>= \x -> pure (thFieldName f, x)) $ thUniqueKeyFields unique+ let mkFieldPat f = maybe wildP varP $ lookup (thFieldName f) uniqueFields+ let pat = conP (thConstrName constr) $ map mkFieldPat $ thConstrFields constr+ let body = foldl (\expr f -> [|$expr $(varE $ snd f)|]) (conE $ mkName $ thUniqueKeyConstrName unique) uniqueFields+ funD 'extractUnique [clause [pat] (normalB body) []]+ uniqueNum' <- do+ let index = findIndex (\u -> thUniqueKeyName unique == thUniqueName u) $ thConstrUniques constr+ let uNum = fromMaybe (error $ "mkUniqueKeysIsUniqueInstances: cannot find unique definition for unique key " ++ thUniqueKeyName unique) index+ funD 'uniqueNum [clause [wildP] (normalB [|uNum|]) []]+ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ pure $ instanceD' context (AppT (ConT ''IsUniqueKey) uniqKeyType) [extractUnique', uniqueNum']++mkUniqueKeysEmbeddedInstances :: THEntityDef -> Q [Dec]+mkUniqueKeysEmbeddedInstances def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ fmap concat $+ forM (filter thUniqueKeyMakeEmbedded $ thUniqueKeys def) $ \unique -> do+ uniqKeyType <- [t|Key $(pure 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 (thDataName def)) $ map extractType $ thTypeParams def+ forM (thUniqueKeys def) $ \unique -> do+ uniqKeyType <- [t|Key $(pure 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"+ proxy <- newName "p"+ let mkField f = do+ let fname = thDbFieldName f+ nvar = [|undefined :: $(pure $ thFieldType f)|]+ typ = mkType f proxy nvar+ [|(fname, $typ)|]+ let embedded = [|EmbeddedDef False $(listE $ map mkField $ thUniqueKeyFields unique)|]+ e = [|entityDef $(varE proxy) ((undefined :: Key v a -> v) $(varE a))|]+ body = [|DbEmbedded $embedded (Just (Left ($e, Just $(lift $ thUniqueKeyName unique)), Nothing, Nothing))|]+ funD 'dbType [clause [varP proxy, varP a] (normalB body) []]+ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ let decs = [persistName', toPersistValues', fromPersistValues', dbType']+ pure $ instanceD' context (AppT (ConT ''PersistField) uniqKeyType) decs++mkUniqueKeysPrimitiveOrPurePersistFieldInstances :: THEntityDef -> Q [Dec]+mkUniqueKeysPrimitiveOrPurePersistFieldInstances def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ fmap concat $+ forM (thUniqueKeys def) $ \unique -> do+ uniqKeyType <- [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]+ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ let conName = mkName $ thUniqueKeyConstrName unique+ isUniquePrim <- case thUniqueKeyFields unique of+ [uniq] -> isPrim $ thFieldType uniq+ _ -> pure False+ if isUniquePrim+ then do+ x <- newName "x"+ toPrim' <- do+ funD 'toPrimitivePersistValue [clause [conP conName [varP x]] (normalB [|toPrimitivePersistValue $(varE x)|]) []]+ fromPrim' <- funD 'fromPrimitivePersistValue [clause [varP x] (normalB [|$(conE conName) (fromPrimitivePersistValue $(varE x))|]) []]+ let decs = [toPrim', fromPrim']+ sequence+ [ pure $ instanceD' context (AppT (ConT ''PrimitivePersistField) uniqKeyType) decs,+ mkDefaultPurePersistFieldInstance context uniqKeyType,+ mkDefaultSinglePersistFieldInstance context uniqKeyType+ ]+ else mkPurePersistFieldInstance uniqKeyType conName (thUniqueKeyFields unique) context++mkKeyEqShowInstances :: THEntityDef -> Q [Dec]+mkKeyEqShowInstances def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ let keysInfo =+ maybe [] (\k -> [(thAutoKeyConstrName k, 1, [t|BackendSpecific|])]) (thAutoKey def)+ ++ map (\k -> (thUniqueKeyConstrName k, length $ thUniqueKeyFields k, [t|Unique $(conT $ mkName $ thUniqueKeyPhantomName k)|])) (thUniqueKeys def)+ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ typ <- [t|Key $(pure entity) $(newName "a" >>= varT)|]++ showsPrec' <-+ let mkClause (cName, fieldsNum, _) = do+ p <- newName "p"+ fields <- replicateM fieldsNum (newName "x")+ let pat = conP (mkName cName) $ map varP fields+ showC = [|showString $(lift $ cName ++ " ")|]+ showArgs = foldr1 (\a b -> [|$a . showString " " . $b|]) $ map (\a -> [|showsPrec 11 $(varE a)|]) fields+ body = [|showParen ($(varE p) >= (11 :: Int)) ($showC . $showArgs)|]+ clause [varP p, pat] (normalB body) []+ in funD 'showsPrec $ map mkClause keysInfo++ eq' <-+ let mkClause (cName, fieldsNum, _) = do+ let fields = replicateM fieldsNum (newName "x")+ (fields1, fields2) <- liftM2 (,) fields fields+ let mkPat = conP (mkName cName) . map varP+ body = foldr1 (\e1 e2 -> [|$e1 && $e2|]) $ zipWith (\n1 n2 -> [|$(varE n1) == $(varE n2)|]) fields1 fields2+ clause [mkPat fields1, mkPat fields2] (normalB body) []+ clauses = map mkClause keysInfo+ noMatch = if length clauses > 1 then [clause [wildP, wildP] (normalB [|False|]) []] else []+ in funD '(==) $ clauses ++ noMatch++ read' <-+ let mkRead (cName, fieldsNum, u) = do+ let key =+ foldl (\a b -> [|$a <*> $b|]) [|$(conE $ mkName cName) <$> R.step R.readPrec|] $+ replicate (fieldsNum - 1) [|R.step R.readPrec|]+ body = [|R.parens $ R.prec 10 $ R.expectP (R.Ident $(litE $ StringL cName)) >> $key|]+ keyType <- [t|Key $(pure entity) $u|]+ readPrec' <- funD 'R.readPrec [clause [] (normalB body) []]+ readListPrec' <- funD 'R.readListPrec [clause [] (normalB [|R.readListPrecDefault|]) []]+ pure $ instanceD' context (AppT (ConT ''Read) keyType) [readPrec', readListPrec']+ in mapM mkRead keysInfo++ pure $+ if null keysInfo+ then []+ else [instanceD' context (AppT (ConT ''Eq) typ) [eq'], instanceD' context (AppT (ConT ''Show) typ) [showsPrec']] ++ read'++mkEmbeddedInstance :: THEmbeddedDef -> Q [Dec]+mkEmbeddedInstance def = do+ let types = map extractType $ thEmbeddedTypeParams def+ embedded = foldl AppT (ConT (thEmbeddedName def)) types+ context = paramsContext (thEmbeddedTypeParams def) (thEmbeddedFields def)+ mkEmbeddedInstance' embedded (thEmbeddedFields def) context++mkEmbeddedInstance' :: Type -> [THFieldDef] -> Cxt -> Q [Dec]+mkEmbeddedInstance' dataType fDefs context = do+ selector' <- do+ fParam <- newName "f"+ let mkField field = ForallC [] [equalP' (VarT fParam) (thFieldType field)] $ NormalC (mkName $ thExprName field) []+ pure $ dataInstD' [] ''Selector [dataType, VarT fParam] (map mkField fDefs) []++ selectorNum' <- do+ let mkClause fNum field = clause [conP (mkName $ thExprName field) []] (normalB $ lift fNum) []+ clauses = zipWith mkClause [0 :: Int ..] fDefs+ funD 'selectorNum clauses++ let decs = [selector', selectorNum']+ pure [instanceD' context (AppT (ConT ''Embedded) dataType) decs]++mkEntityPhantomConstructors :: THEntityDef -> Q [Dec]+mkEntityPhantomConstructors def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ forM (thConstructors def) $ \c -> do+ v <- newName "v"+ let name = mkName $ thPhantomConstrName c+ phantom <- [t|ConstructorMarker $(pure entity)|]+ let constr = GadtC [name] [] (AppT (ConT name) phantom)+ pure $ dataD' [] name [plainTV v] [constr] []++mkEntityPhantomConstructorInstances :: THEntityDef -> Q [Dec]+mkEntityPhantomConstructorInstances def = zipWithM f [0 ..] (thConstructors def)+ where+ f :: Int -> THConstructorDef -> Q Dec+ f cNum c = instanceD (cxt []) (appT (conT ''Constructor) (conT $ mkName $ thPhantomConstrName c)) [phantomConstrNum']+ where+ phantomConstrNum' = funD 'phantomConstrNum [clause [wildP] (normalB [|cNum|]) []]++mkEntityUniqueKeysPhantoms :: THEntityDef -> Q [Dec]+mkEntityUniqueKeysPhantoms def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def+ fmap concat $+ forM (thUniqueKeys def) $ \u -> do+ exists <- lookupTypeName $ thUniqueKeyPhantomName u+ if isNothing exists+ then do+ v <- newName "v"+ let name = mkName $ thUniqueKeyPhantomName u+ phantom <- [t|UniqueMarker $(pure entity)|]+ let constr = GadtC [name] [] (AppT (ConT name) phantom)+ pure [dataD' [] name [plainTV v] [constr] []]+ else pure []++mkPersistEntityInstance :: THEntityDef -> Q [Dec]+mkPersistEntityInstance def = do+ let entity = foldl AppT (ConT (thDataName def)) $ map extractType $ thTypeParams def++ key' <- do+ uParam <- newName "u"+ autoKey <- case thAutoKey def of+ Nothing -> pure []+ Just k -> do+ keyDescr <- [t|BackendSpecific|]+ pure [ForallC [] [equalP' (VarT uParam) keyDescr] $ NormalC (mkName $ thAutoKeyConstrName k) [(notStrict', ConT ''PersistValue)]]+ uniques <- forM (thUniqueKeys def) $ \unique -> do+ uniqType <- [t|Unique $(conT $ mkName $ thUniqueKeyPhantomName unique)|]+ let cDef = head $ thConstructors def+ uniqFieldNames = lefts $ thUniqueFields $ findOne "unique" thUniqueName (thUniqueKeyName unique) $ thConstrUniques cDef+ uniqFields = concat $ flip map uniqFieldNames $ \name -> filter ((== name) . thFieldName) $ thConstrFields cDef+ uniqFields' = map (\f -> (notStrict', thFieldType f)) uniqFields+ pure $ ForallC [] [equalP' (VarT uParam) uniqType] $ NormalC (mkName $ thUniqueKeyConstrName unique) uniqFields'+ pure $ dataInstD' [] ''Key [entity, VarT uParam] (autoKey ++ uniques) []++ autoKey' <- do+ autoType <- case thAutoKey def of+ Nothing -> [t|()|]+ Just _ -> [t|Key $(pure entity) BackendSpecific|]+ pure $ mkTySynInstD ''AutoKey [entity] autoType++ defaultKey' <- do+ typ <- case thAutoKey def of+ Just k | thAutoKeyIsDef k -> [t|Key $(pure entity) BackendSpecific|]+ _ -> case filter thUniqueKeyIsDef $ thUniqueKeys def of+ [unique] -> [t|Key $(pure entity) (Unique $(conT $ mkName $ thUniqueKeyPhantomName unique))|]+ _ -> [t|()|]+ pure $ mkTySynInstD ''DefaultKey [entity] typ++ isSumType' <- do+ let isSumType =+ ConT $+ if length (thConstructors def) == 1+ then ''HFalse+ else ''HTrue+ pure $ mkTySynInstD ''IsSumType [entity] isSumType++ fields' <- do+ cParam <- newName "c"+ fParam <- newName "f"+ let mkField name field = ForallC [] [equalP' (VarT cParam) (ConT name), equalP' (VarT fParam) (thFieldType field)] $ NormalC (mkName $ thExprName field) []+ let f cdef = map (mkField $ mkName $ thPhantomConstrName cdef) $ thConstrFields cdef+ let constrs = concatMap f $ thConstructors def+ pure $ dataInstD' [] ''Field [entity, VarT cParam, VarT fParam] constrs []++ entityDef' <- do+ v <- newName "v"+ proxy <- newName "p"+ let mkLambda t = [|undefined :: $(pure entity) -> $(pure t)|]+ types = map extractType $ thTypeParams def+ typeParams' = listE $ map (\t -> [|dbType $(varE proxy) ($(mkLambda t) $(varE v))|]) types+ mkField c fNum f = do+ a <- newName "a"+ let fname = thDbFieldName f+ nvar =+ if hasFreeVars (thFieldType f)+ then+ let pat = conP (thConstrName c) $ replicate fNum wildP ++ [varP a] ++ replicate (length (thConstrFields c) - fNum - 1) wildP+ wildClause = if length (thConstructors def) > 1 then [match wildP (normalB [|undefined|]) []] else []+ in caseE (varE v) (match pat (normalB $ varE a) [] : wildClause)+ else [|undefined :: $(pure $ thFieldType f)|]+ typ = mkType f proxy nvar+ [|(fname, $typ)|]+ constrs = listE $ map mkConstructorDef $ thConstructors def+ mkConstructorDef c@(THConstructorDef _ _ name keyName params conss) = [|ConstructorDef name keyName $(listE $ map snd fields) $(listE $ map mkConstraint conss)|]+ where+ fields = zipWith (\i f -> (thFieldName f, mkField c i f)) [0 ..] params+ mkConstraint (THUniqueDef uName uType uFields) = [|UniqueDef (Just uName) uType $(listE $ map getField uFields)|]+ getField (Left fName) = [|Left $(snd $ findOne "field" fst fName fields)|]+ getField (Right expr) = [|Right expr|]++ paramNames = foldr1 (\p xs -> [|$p ++ [delim] ++ $xs|]) $ map (\t -> [|persistName ($(mkLambda t) $(varE v))|]) types+ fullEntityName =+ if null types+ then [|$(stringE $ thDbEntityName def)|]+ else [|$(stringE $ thDbEntityName def) ++ [delim] ++ $(paramNames)|]++ body = normalB [|EntityDef $fullEntityName $(lift $ thEntitySchema def) $typeParams' $constrs|]+ entityPat = if null $ thTypeParams def then wildP else varP v+ funD 'entityDef [clause [varP proxy, entityPat] body []]++ toEntityPersistValues' <- fmap (FunD 'toEntityPersistValues) $+ forM (zip [0 :: Int ..] $ thConstructors def) $ \(cNum, c) -> do+ (pat, body) <- mkToPersistValues (thConstrName c) (thConstrFields c) (\result -> [|(toPrimitivePersistValue ($(lift cNum) :: Int) :) . $result|])+ clause [pat] (normalB body) []++ fromEntityPersistValues' <- do+ xs <- newName "xs"+ let failureBody = normalB [|fail (failMessageNamed $(stringE $ show $ thDataName def) $(varE xs))|]+ failureName <- newName "failure"+ let failure = match wildP (normalB $ varE failureName) []+ matches <- forM (zip [0 ..] (thConstructors def)) $ \(cNum, c) -> do+ let cNum' = conP 'PersistInt64 [litP $ integerL cNum]+ xs' <- newName "xs"+ (_, body) <- mkFromPersistValues failureName xs' (thConstrName c) (thConstrFields c)+ pure $ match (infixP cNum' '(:) (varP xs')) (normalB $ pure body) []+ let start = caseE (varE xs) $ matches ++ [failure]+ let failureFunc = funD failureName [clause [] failureBody []]+ funD 'fromEntityPersistValues [clause [varP xs] (normalB start) [failureFunc]]++ getUniques' <-+ let hasConstraints = not . null . thConstrUniques+ clauses = zipWith mkClause [0 :: Int ..] (thConstructors def)+ mkClause cNum cdef | not (hasConstraints cdef) = clause [conP (thConstrName cdef) pats] (normalB [|(cNum, [])|]) []+ where+ pats = map (const wildP) $ thConstrFields cdef+ mkClause cNum cdef = do+ let allConstrainedFields = lefts $ concatMap thUniqueFields $ thConstrUniques cdef+ vars <- mapM (\f -> newName "x" >>= \x -> pure $ if thFieldName f `elem` allConstrainedFields then Just (x, f) else Nothing) $ thConstrFields cdef+ let pat = conP (thConstrName cdef) $ map (maybe wildP (varP . fst)) vars+ body = normalB [|(cNum, $(listE $ mapMaybe mkUnique $ thConstrUniques cdef))|]+ mkUnique (THUniqueDef uName _ fnames) =+ if null $ rights fnames+ then+ let -- find corresponding field from vars+ uFields = map (\f -> findOne "field" (thFieldName . snd) f $ catMaybes vars) $ lefts fnames+ result = mkToPurePersistValues uFields+ in Just [|(uName, $result)|]+ else Nothing+ clause [pat] body []+ in funD 'getUniques clauses++ entityFieldChain' <-+ let thFieldNames = thConstructors def >>= thConstrFields+ clauses = map mkClause thFieldNames+ mkClause f = do+ fArg <- newName "f"+ proxy <- newName "p"+ let nvar = [|(undefined :: Field v c a -> a) $(varE fArg)|]+ typ = mkType f proxy nvar+ body = [|(($(lift $ thDbFieldName f), $typ), [])|]+ clause [varP proxy, asP fArg $ conP (mkName $ thExprName f) []] (normalB body) []+ clauses' = if null clauses then [clause [wildP] (normalB [|undefined|]) []] else clauses+ in funD 'entityFieldChain clauses'++ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ let decs = [key', autoKey', defaultKey', isSumType', fields', entityDef', toEntityPersistValues', fromEntityPersistValues', getUniques', entityFieldChain']+ pure [instanceD' context (AppT (ConT ''PersistEntity) entity) decs]++mkToPurePersistValues :: [(Name, THFieldDef)] -> Q Exp+mkToPurePersistValues vars = do+ let processField (fName, fDef) = do+ isP <- isPrim (thFieldType fDef)+ let field = maybe id (\convName x -> [|fst $(varE convName) $ $x|]) (thFieldConverter fDef) (varE fName)+ if isP+ then pure (Nothing, [|(toPrimitivePersistValue $field :)|])+ else newName "x" >>= \x -> pure (Just $ valD (varP x) (normalB [|toPurePersistValues $(varE fName)|]) [], varE x)+ (lets, funcs) <- fmap (first catMaybes . unzip) $ mapM processField vars+ let result = if null funcs then [|id|] else foldr1 (\a b -> [|$a . $b|]) funcs+ if null lets then result else letE lets result++mkEntityPersistFieldInstance :: THEntityDef -> Q [Dec]+mkEntityPersistFieldInstance def = case getDefaultKey def of+ Just defaultKey -> do+ let types = map extractType $ thTypeParams def+ let entity = foldl AppT (ConT (thDataName def)) types++ persistName' <- do+ v <- newName "v"+ let mkLambda t = [|undefined :: $(pure entity) -> $(pure t)|]++ let paramNames = foldr1 (\p xs -> [|$p ++ [delim] ++ $xs|]) $ map (\t -> [|persistName ($(mkLambda t) $(varE v))|]) types+ let fullEntityName = case types of+ [] -> [|$(stringE $ thDbEntityName def)|]+ _ -> [|$(stringE $ thDbEntityName 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 mUniqName = either auto uniq defaultKey+ where+ auto _ = Nothing+ uniq u = Just $ mkName $ thUniqueKeyPhantomName u++ toPersistValues' <- do+ let body = normalB $ case mUniqName of+ _ | isOne -> [|singleToPersistValue|]+ Just name -> [|toPersistValuesUnique $(conE name)|]+ _ -> error "mkEntityPersistFieldInstance: key has no unique type"+ funD 'toPersistValues [clause [] body []]++ fromPersistValues' <- do+ let body = normalB $ case mUniqName of+ _ | isOne -> [|singleFromPersistValue|]+ Just name -> [|fromPersistValuesUnique $(conE name)|]+ _ -> error "mkEntityPersistFieldInstance: key has no unique type"+ funD 'fromPersistValues [clause [] body []]++ dbType' <- do+ proxy <- newName "p"+ let body = [|dbType $(varE proxy) . (undefined :: a -> DefaultKey a)|]+ funD 'dbType [clause [varP proxy] (normalB body) []]++ let context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ let decs = [persistName', toPersistValues', fromPersistValues', dbType']+ pure [instanceD' context (AppT (ConT ''PersistField) entity) decs]+ Nothing -> pure []++mkEntitySinglePersistFieldInstance :: THEntityDef -> Q [Dec]+mkEntitySinglePersistFieldInstance def =+ isDefaultKeyOneColumn def >>= \isOne -> case getDefaultKey def of+ Just defaultKey | isOne -> do+ let types = map extractType $ thTypeParams def+ entity = foldl AppT (ConT (thDataName def)) types+ context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)++ (to, from) = case defaultKey of+ Left _ -> ([|toSinglePersistValueAutoKey|], [|fromSinglePersistValueAutoKey|])+ Right k -> ([|toSinglePersistValueUnique $u|], [|fromSinglePersistValueUnique $u|])+ where+ u = conE $ mkName $ thUniqueKeyPhantomName k++ toSinglePersistValue' <- funD 'toSinglePersistValue [clause [] (normalB to) []]+ fromSinglePersistValue' <- funD 'fromSinglePersistValue [clause [] (normalB from) []]+ let decs = [toSinglePersistValue', fromSinglePersistValue']+ pure [instanceD' context (AppT (ConT ''SinglePersistField) entity) decs]+ _ -> pure []++mkEntityNeverNullInstance :: THEntityDef -> Q [Dec]+mkEntityNeverNullInstance def = do+ let types = map extractType $ thTypeParams def+ entity = foldl AppT (ConT (thDataName def)) types+ context = paramsContext (thTypeParams def) (thConstructors def >>= thConstrFields)+ isOne <- isDefaultKeyOneColumn def+ pure $+ if isOne+ then [instanceD' context (AppT (ConT ''NeverNull) entity) []]+ else []++mkPrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]+mkPrimitivePersistFieldInstance def = do+ let primitive = ConT (thPrimitiveName def)+ persistName' <- do+ let body = normalB $ stringE $ nameBase $ thPrimitiveName def+ funD 'persistName [clause [wildP] body []]+ fromPersistValues' <- funD 'fromPersistValues [clause [] (normalB [|primFromPersistValue|]) []]+ toPersistValues' <- funD 'toPersistValues [clause [] (normalB [|primToPersistValue|]) []]+ dbType' <- do+ proxy <- newName "p"+ x <- newName "x"+ let body = [|dbType $(varE proxy) $ fst $(varE $ thPrimitiveConverter def) $(varE x)|]+ funD 'dbType [clause [varP proxy, varP x] (normalB body) []]+ let decs = [persistName', toPersistValues', fromPersistValues', dbType']+ pure+ [ instanceD' [] (AppT (ConT ''PersistField) primitive) decs,+ instanceD' [] (AppT (ConT ''NeverNull) primitive) []+ ]++mkPrimitivePrimitivePersistFieldInstance :: THPrimitiveDef -> Q [Dec]+mkPrimitivePrimitivePersistFieldInstance def = do+ let primitive = ConT (thPrimitiveName def)+ toPrim' <- do+ let body = [|toPrimitivePersistValue . fst $(varE $ thPrimitiveConverter def)|]+ funD 'toPrimitivePersistValue [clause [] (normalB body) []]+ fromPrim' <- do+ let body = [|snd $(varE $ thPrimitiveConverter def) . fromPrimitivePersistValue|]+ funD 'fromPrimitivePersistValue [clause [] (normalB body) []]+ let context = []+ let decs = [toPrim', fromPrim']+ sequence+ [ pure $ instanceD' context (AppT (ConT ''PrimitivePersistField) primitive) decs,+ mkDefaultPurePersistFieldInstance context primitive,+ mkDefaultSinglePersistFieldInstance context primitive+ ]++mkMigrateFunction :: String -> [THEntityDef] -> Q [Dec]+mkMigrateFunction name defs = do+ let (normal, polymorhpic) = partition (null . thTypeParams) defs+ forM_ polymorhpic $ \def -> reportWarning $ "Datatype " ++ show (thDataName def) ++ " will not be migrated automatically by function " ++ name ++ " because it has type parameters"+ let body = doE $ map (\def -> noBindS [|migrate (undefined :: $(conT $ thDataName def))|]) normal+ sig <- sigD (mkName name) [t|forall m. PersistBackend m => Migration m|]+ func <- funD (mkName name) [clause [] (normalB body) []]+ pure [sig, func]++isDefaultKeyOneColumn :: THEntityDef -> Q Bool+isDefaultKeyOneColumn def = case getDefaultKey def of+ Just (Left _) -> pure True+ Just (Right unique) -> case thUniqueKeyFields unique of+ [field] -> isPrim $ thFieldType field+ _ -> pure False+ _ -> pure False++getDefaultKey :: THEntityDef -> Maybe (Either THAutoKeyDef THUniqueKeyDef)+getDefaultKey def = case thAutoKey def of+ Just k | thAutoKeyIsDef k -> Just $ Left k+ _ -> case filter thUniqueKeyIsDef $ thUniqueKeys def of+ [] -> Nothing+ (u : _) -> Just $ Right u++#if MIN_VERSION_template_haskell(2, 17, 0)+paramsContext :: [TH.TyVarBndr flag] -> [THFieldDef] -> Cxt+#else+paramsContext :: [TyVarBndr] -> [THFieldDef] -> Cxt+#endif+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 . thFieldType++#if MIN_VERSION_template_haskell(2, 17, 0)+paramsPureContext :: [TH.TyVarBndr flag] -> [THFieldDef] -> Q (Maybe Cxt)+#else+paramsPureContext :: [TyVarBndr] -> [THFieldDef] -> Q (Maybe Cxt)+#endif+paramsPureContext types fields = do+ let isValidType (VarT _) = pure True+ isValidType t = isPrim t+ invalid <- filterM (fmap not . isValidType . thFieldType) fields+ pure $ 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 . thFieldType+ _ -> Nothing++#if MIN_VERSION_template_haskell(2, 17, 0)+extractType :: TH.TyVarBndr flag -> Type+extractType (PlainTV name _) = VarT name+extractType (KindedTV name _ _) = VarT name+#else+extractType :: TyVarBndr -> Type+extractType (PlainTV name) = VarT name+extractType (KindedTV name _) = VarT name+#endif++#if MIN_VERSION_template_haskell(2, 7, 0)+#define isClassInstance isInstance+#endif++#if !MIN_VERSION_template_haskell(2, 8, 0)+reportWarning :: String -> Q ()+reportWarning = report False+#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 = pure 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 = pure True+isPrim (AppT (ConT tcon) t) | tcon == ''Maybe = isPrim t+isPrim _ = pure False++foldType :: (Type -> a) -> (a -> a -> a) -> Type -> a+foldType f app = go+ where+ go ForallT {} = error "forall'ed fields are not allowed"+ go z@(AppT a b) = f z `app` go a `app` go b+ go z@(SigT t _) = f z `app` 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 [] = pure ([], [])+ go (x : xs) = do+ flg <- p x+ if flg+ then do+ (ys, zs) <- go xs+ pure (x : ys, zs)+ else pure ([], x : xs)++mkType :: THFieldDef -> Name -> ExpQ -> ExpQ+mkType THFieldDef {..} proxy nvar = t3+ where+ psField = PSFieldDef thFieldName (Just thDbFieldName) thDbTypeName (Just thExprName) thEmbeddedDef thDefaultValue thReferenceParent (fmap show thFieldConverter)+ t1 = maybe id (\convName x -> [|fst $(varE convName) $ $x|]) thFieldConverter nvar+ t2 = [|dbType $(varE proxy) $t1|]+ -- if there are any type settings, apply them in runtime+ t3 = case (thDbTypeName, thEmbeddedDef, thDefaultValue, thReferenceParent) of+ (Nothing, Nothing, Nothing, Nothing) -> t2+ _ -> [|applyDbTypeSettings $(lift psField) $t2|]++mkTySynInstD :: Name -> [Type] -> Type -> Dec+#if MIN_VERSION_template_haskell(2, 15, 0)+mkTySynInstD name ts t =+ TySynInstD $ TySynEqn Nothing typ t where+ typ = foldl AppT (ConT name) ts+#elif MIN_VERSION_template_haskell(2, 9, 0)+mkTySynInstD name ts t = TySynInstD name $ TySynEqn ts t+#else+mkTySynInstD = TySynInstD+#endif++classP' :: Name -> [Type] -> Pred+#if MIN_VERSION_template_haskell(2, 10, 0)+classP' name ts = foldl AppT (ConT name) ts+#else+classP' = ClassP+#endif++equalP' :: Type -> Type -> Pred+#if MIN_VERSION_template_haskell(2, 10, 0)+equalP' t1 t2 = foldl AppT EqualityT [t1, t2]+#else+equalP'= EqualP+#endif++instanceD' :: Cxt -> Type -> [Dec] -> InstanceDec+#if MIN_VERSION_template_haskell(2, 11, 0)+instanceD' = InstanceD Nothing+#else+instanceD' = InstanceD+#endif++dataInstD' :: Cxt -> Name -> [Type] -> [Con] -> [Name] -> InstanceDec+#if MIN_VERSION_template_haskell(2, 15, 0)+dataInstD' context name types constrs derives =+ DataInstD context Nothing typ Nothing constrs [DerivClause Nothing (map ConT derives)] where+ typ = foldl AppT (ConT name) types+#elif MIN_VERSION_template_haskell(2, 12, 0)+dataInstD' context name types constrs derives =+ DataInstD context name types Nothing constrs [DerivClause Nothing (map ConT derives)]+#elif MIN_VERSION_template_haskell(2, 11, 0)+dataInstD' context name types constrs derives =+ DataInstD context name types Nothing constrs (map ConT derives)+#else+dataInstD' = DataInstD+#endif++dataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> InstanceDec++#if MIN_VERSION_template_haskell(2, 12, 0)+dataD' context name types constrs derives =+ DataD context name types Nothing constrs [DerivClause Nothing (map ConT derives)]+#elif MIN_VERSION_template_haskell(2, 11, 0)+dataD' context name types constrs derives =+ DataD context name types Nothing constrs (map ConT derives)+#else+dataD' = DataD+#endif++#if MIN_VERSION_template_haskell(2, 11, 0)+notStrict' :: Bang+notStrict' = Bang NoSourceUnpackedness NoSourceStrictness+#else+notStrict' :: Strict+notStrict' = NotStrict+#endif++#if MIN_VERSION_template_haskell(2, 17, 0)+type TyVarBndr = TH.TyVarBndr ()+#else+type TyVarBndr = TH.TyVarBndr+#endif
Database/Groundhog/TH/Settings.hs view
@@ -1,334 +1,355 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, OverloadedStrings, RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Database.Groundhog.TH.Settings - ( PersistDefinitions(..) - , THEntityDef(..) - , THEmbeddedDef(..) - , THPrimitiveDef(..) - , THConstructorDef(..) - , THFieldDef(..) - , THUniqueDef(..) - , THUniqueKeyDef(..) - , THAutoKeyDef(..) - , PSEntityDef(..) - , PSEmbeddedDef(..) - , PSPrimitiveDef(..) - , PSConstructorDef(..) - , PSFieldDef(..) - , PSUniqueDef(..) - , PSUniqueKeyDef(..) - , PSAutoKeyDef(..) - ) where - -import Database.Groundhog.Core (UniqueType(..), ReferenceActionType(..)) -import Database.Groundhog.Generic (PSFieldDef(..)) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (Lift(..)) -import Control.Applicative -import Control.Monad (forM, mzero, when) -import Data.Aeson -import Data.Aeson.Types (Pair) -import qualified Data.Foldable as Fold -import qualified Data.HashMap.Strict as H -import Data.Maybe (catMaybes) -import Data.Text (Text) - -data PersistDefinitions = PersistDefinitions {psEntities :: [PSEntityDef], psEmbeddeds :: [PSEmbeddedDef], psPrimitives :: [PSPrimitiveDef]} deriving Show - --- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq) - -data THEntityDef = THEntityDef { - thDataName :: Name -- SomeData - , thDbEntityName :: String -- SQLSomeData - , thEntitySchema :: Maybe String - , thAutoKey :: Maybe THAutoKeyDef - , thUniqueKeys :: [THUniqueKeyDef] - , thTypeParams :: [TyVarBndr] - , thConstructors :: [THConstructorDef] -} deriving (Eq, Show) - -data THAutoKeyDef = THAutoKeyDef { - thAutoKeyConstrName :: String - , thAutoKeyIsDef :: Bool -} deriving (Eq, Show) - -data THEmbeddedDef = THEmbeddedDef { - thEmbeddedName :: Name - , thEmbeddedConstructorName :: Name - , thDbEmbeddedName :: String -- ^ It is used only to set polymorphic part of name of its container - , thEmbeddedTypeParams :: [TyVarBndr] - , thEmbeddedFields :: [THFieldDef] -} deriving (Eq, Show) - -data THPrimitiveDef = THPrimitiveDef { - thPrimitiveName :: Name - , thPrimitiveDbName :: String -- ^ It is used only to set polymorphic part of name of its container - , thPrimitiveConverter :: Name -- ^ Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField` -} deriving (Eq, Show) - -data THConstructorDef = THConstructorDef { - thConstrName :: Name -- U2 - , thPhantomConstrName :: String -- U2Constructor - , thDbConstrName :: String -- SQLU2 - , thDbAutoKeyName :: Maybe String -- u2_id - , thConstrFields :: [THFieldDef] - , thConstrUniques :: [THUniqueDef] -} deriving (Eq, Show) - -data THFieldDef = THFieldDef { - thFieldName :: String -- ^ name in the record, bar - , thDbFieldName :: String -- ^ column name, SQLbar - , thDbTypeName :: Maybe String -- ^ column type, inet, NUMERIC(5, 2), VARCHAR(50), etc. - , thExprName :: String -- ^ name of constructor in the Field GADT, BarField - , thFieldType :: Type - , thEmbeddedDef :: Maybe [PSFieldDef String] - , thDefaultValue :: Maybe String -- ^ default value in the database - , thReferenceParent :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType) - , thFieldConverter :: Maybe Name -- ^ name of a pair of functions -} deriving (Eq, Show) - -data THUniqueDef = THUniqueDef { - thUniqueName :: String - , thUniqueType :: UniqueType - , thUniqueFields :: [Either String String] -- ^ Either name of field, i.e, thFieldName, or expression -} deriving (Eq, Show) - -data THUniqueKeyDef = THUniqueKeyDef { - thUniqueKeyName :: String - , thUniqueKeyPhantomName :: String - , thUniqueKeyConstrName :: String - , thUniqueKeyDbName :: String -- ^ It is used only to set polymorphic part of name of its container - -- | It should repeat fields from THUniqueDef but it may give different settings for them. It is done to allow foreign key fields to be different from parent fields of the entity. These fields are used for creating a the key constructor and instances for it. For example, it can have a default value, or even a different type (INT8 may reference INT4). - , thUniqueKeyFields :: [THFieldDef] - , thUniqueKeyMakeEmbedded :: Bool -- ^ If True, make it an instance of Embedded - , thUniqueKeyIsDef :: Bool -} deriving (Eq, Show) - -data PSEntityDef = PSEntityDef { - psDataName :: String -- SomeData - , psDbEntityName :: Maybe String -- SQLSomeData - , psEntitySchema :: Maybe String - , psAutoKey :: Maybe (Maybe PSAutoKeyDef) -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings - , psUniqueKeys :: Maybe [PSUniqueKeyDef] - , psConstructors :: Maybe [PSConstructorDef] -} deriving (Eq, Show) - -data PSEmbeddedDef = PSEmbeddedDef { - psEmbeddedName :: String - , psDbEmbeddedName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container - , psEmbeddedFields :: Maybe [PSFieldDef String] -} deriving (Eq, Show) - -data PSPrimitiveDef = PSPrimitiveDef { - psPrimitiveName :: String - , psPrimitiveDbName :: Maybe String -- ^ It is used only to set polymorphic part of name of its container - , psPrimitiveConverter :: String -- ^ Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField` -} deriving (Eq, Show) - -data PSConstructorDef = PSConstructorDef { - psConstrName :: String -- U2 - , psPhantomConstrName :: Maybe String -- U2Constructor - , psDbConstrName :: Maybe String -- SQLU2 - , psDbAutoKeyName :: Maybe String -- u2_id - , psConstrFields :: Maybe [PSFieldDef String] - , psConstrUniques :: Maybe [PSUniqueDef] -} deriving (Eq, Show) - -data PSUniqueDef = PSUniqueDef { - psUniqueName :: String - , psUniqueType :: Maybe UniqueType - , psUniqueFields :: [Either String String] -} deriving (Eq, Show) - -data PSUniqueKeyDef = PSUniqueKeyDef { - psUniqueKeyName :: String - , psUniqueKeyPhantomName :: Maybe String - , psUniqueKeyConstrName :: Maybe String - , psUniqueKeyDbName :: Maybe String - , psUniqueKeyFields :: Maybe [PSFieldDef String] - , psUniqueKeyMakeEmbedded :: Maybe Bool - , psUniqueKeyIsDef :: Maybe Bool -} deriving (Eq, Show) - -data PSAutoKeyDef = PSAutoKeyDef { - psAutoKeyConstrName :: Maybe String - , psAutoKeyIsDef :: Maybe Bool -} deriving (Eq, Show) - -instance Lift PSPrimitiveDef where - lift (PSPrimitiveDef {..}) = [| PSPrimitiveDef $(lift psPrimitiveName) $(lift psPrimitiveDbName) $(lift psPrimitiveConverter) |] - -instance Lift PersistDefinitions where - lift (PersistDefinitions {..}) = [| PersistDefinitions $(lift psEntities) $(lift psEmbeddeds) $(lift psPrimitives) |] - -instance Lift PSEntityDef where - lift (PSEntityDef {..}) = [| PSEntityDef $(lift psDataName) $(lift psDbEntityName) $(lift psEntitySchema) $(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 typ fields) = [| PSUniqueDef $(lift name) $(lift typ) $(lift fields) |] - -instance Lift UniqueType where - lift UniqueConstraint = [| UniqueConstraint |] - lift UniqueIndex = [| UniqueIndex |] - lift (UniquePrimary x) = [| UniquePrimary $(lift x) |] - -instance Lift ReferenceActionType where - lift NoAction = [| NoAction |] - lift Restrict = [| Restrict |] - lift Cascade = [| Cascade |] - lift SetNull = [| SetNull |] - lift SetDefault = [| SetDefault |] - -instance Lift (PSFieldDef String) where - lift (PSFieldDef {..}) = [| PSFieldDef $(lift psFieldName) $(lift psDbFieldName) $(lift psDbTypeName) $(lift psExprName) $(lift psEmbeddedDef) $(lift psDefaultValue) $(lift psReferenceParent) $(lift psFieldConverter) |] - -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 = (case value of - Object v -> do - defs <- v .:? "definitions" - case defs of - Just (Array arr) -> Fold.foldrM go initial arr - Nothing -> go value initial - Just _ -> mzero - Array arr -> Fold.foldrM go initial arr - _ -> mzero) where - initial = PersistDefinitions [] [] [] - go obj p@(PersistDefinitions{..}) = flip (withObject "definition") obj $ \v -> case () of - _ | H.member "entity" v -> (\x -> p {psEntities = x:psEntities}) <$> parseJSON obj - _ | H.member "embedded" v -> (\x -> p {psEmbeddeds = x:psEmbeddeds}) <$> parseJSON obj - _ | H.member "primitive" v -> (\x -> p {psPrimitives = x:psPrimitives}) <$> parseJSON obj - _ -> fail $ "Invalid definition: " ++ show obj - - -instance FromJSON PSEntityDef where - parseJSON = withObject "entity" $ \v -> - PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> v .:? "schema" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors" - -instance FromJSON PSEmbeddedDef where - parseJSON = withObject "embedded" $ \v -> - PSEmbeddedDef <$> v .: "embedded" <*> v .:? "dbName" <*> v .:? "fields" - -instance FromJSON PSPrimitiveDef where - parseJSON = withObject "primitive" $ \v -> do - when (H.member "representation" v) $ fail $ "parseJSON: field 'representation' is deprecated. Use 'converter' instead: " ++ show v - PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> v .: "converter" - -instance FromJSON PSConstructorDef where - parseJSON = withObject "constructor" $ \v -> - PSConstructorDef <$> v .: "name" <*> v .:? "phantomName" <*> v .:? "dbName" <*> v .:? "keyDbName" <*> v .:? "fields" <*> v .:? "uniques" - -instance FromJSON PSUniqueDef where - parseJSON = withObject "unique" $ \v -> do - fields <- v .: "fields" - fields' <- forM fields $ \f -> case f of - Object expr -> Right <$> expr .: "expr" - field -> Left <$> parseJSON field - PSUniqueDef <$> v .: "name" <*> v .:? "type" <*> pure fields' - -instance FromJSON UniqueType where - parseJSON o = do - x <- parseJSON o - let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary False)] - case lookup x vals of - Just a -> return a - Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x - -instance FromJSON ReferenceActionType where - parseJSON o = do - x <- parseJSON o - let vals = [("no action", NoAction), ("restrict", Restrict), ("cascade", Cascade), ("set null", SetNull), ("set default", SetDefault)] - case lookup x vals of - Just a -> return a - Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x - -instance FromJSON (PSFieldDef String) where - parseJSON = withObject "field" $ \v -> - PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings v <*> v .:? "converter" where - mkRefSettings v = do - ref <- v .:? "reference" - (parent, onDel, onUpd) <- case ref of - Just (Object r) -> (,,) <$> optional parentRef <*> r .:? "onDelete" <*> r .:? "onUpdate" where - parentRef = (,) <$> ((,) <$> r .:? "schema" <*> r .: "table") <*> r .: "columns" - _ -> pure (Nothing, Nothing, Nothing) - -- this temporary solution uses onDelete and onUpdate both from inside reference object (preferred) and from field level (for compatibility) - (onDel', onUpd') <- (,) <$> v .:? "onDelete" <*> v .:? "onUpdate" - pure $ case (parent, onDel <|> onDel', onUpd <|> onUpd') of - (Nothing, Nothing, Nothing) -> Nothing - refSettings -> Just refSettings - -instance FromJSON PSUniqueKeyDef where - parseJSON = withObject "unique key" $ \v -> - PSUniqueKeyDef <$> v .: "name" <*> v .:? "keyPhantom" <*> v .:? "constrName" <*> v .:? "dbName" <*> v .:? "fields" <*> v .:? "mkEmbedded" <*> v .:? "default" - -instance FromJSON PSAutoKeyDef where - parseJSON = withObject "autogenerated key" $ \v -> - PSAutoKeyDef <$> v .:? "constrName" <*> v .:? "default" - -(.=?) :: ToJSON a => Text -> Maybe a -> Maybe Pair -name .=? value = (name .=) <$> value - -(.=:) :: ToJSON a => Text -> Maybe [a] -> Maybe Pair -name .=: value = case value of - Just (_:_) -> Just $ name .= value - _ -> Nothing - -instance ToJSON PSEntityDef where - toJSON PSEntityDef{..} = object $ catMaybes [Just $ "entity" .= psDataName, "dbName" .=? psDbEntityName, "schema" .=? psEntitySchema, "autoKey" .=? psAutoKey, "keys" .=: psUniqueKeys, "constructors" .=: psConstructors] - -instance ToJSON PSConstructorDef where - toJSON PSConstructorDef{..} = object $ catMaybes [Just $ "name" .= psConstrName, "phantomName" .=? psPhantomConstrName, "dbName" .=? psDbConstrName, "keyDbName" .=? psDbAutoKeyName, "fields" .=: psConstrFields, "uniques" .=: psConstrUniques] - -instance ToJSON PSUniqueDef where - toJSON PSUniqueDef{..} = object $ catMaybes [Just $ "name" .= psUniqueName, "type" .=? psUniqueType, "fields" .=? fields] where - fields = if null psUniqueFields - then Nothing - else Just $ map (either toJSON (\x -> object ["expr" .= x])) psUniqueFields - -instance ToJSON UniqueType where - toJSON a = toJSON $ case a of - UniqueConstraint -> "constraint" :: String - UniqueIndex -> "index" - UniquePrimary _ -> "primary" - -instance ToJSON ReferenceActionType where - toJSON a = toJSON $ case a of - NoAction -> "no action" :: String - Restrict -> "restrict" - Cascade -> "cascade" - SetNull -> "set null" - SetDefault -> "set default" - -instance ToJSON (PSFieldDef String) where - toJSON PSFieldDef{..} = object $ catMaybes [Just $ "name" .= psFieldName, "dbName" .=? psDbFieldName, "type" .=? psDbTypeName, "exprName" .=? psExprName, "embeddedType" .=: psEmbeddedDef, "default" .=? psDefaultValue, "reference" .=? (psReferenceParent >>= mkRefSettings)] where - mkRefSettings (parent, onDel, onUpd) = if null fields then Nothing else Just $ object fields where - fields = catMaybes $ parent' ++ ["onDelete" .=? onDel, "onUpdate" .=? onUpd] - parent' = case parent of - Nothing -> [] - Just ((schema, table), columns) -> ["schema" .=? schema, Just $ "table" .= table, Just $ "columns" .= columns] - -instance ToJSON PSUniqueKeyDef where - toJSON PSUniqueKeyDef{..} = object $ catMaybes [Just $ "name" .= psUniqueKeyName, "keyPhantom" .=? psUniqueKeyPhantomName, "constrName" .=? psUniqueKeyConstrName, "dbName" .=? psUniqueKeyDbName, "mkEmbedded" .=? psUniqueKeyMakeEmbedded, "default" .=? psUniqueKeyIsDef, "fields" .=: psUniqueKeyFields] - -instance ToJSON PSAutoKeyDef where - toJSON PSAutoKeyDef{..} = object $ catMaybes ["constrName" .=? psAutoKeyConstrName, "default" .=? psAutoKeyIsDef] +{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Database.Groundhog.TH.Settings+ ( PersistDefinitions (..),+ THEntityDef (..),+ THEmbeddedDef (..),+ THPrimitiveDef (..),+ THConstructorDef (..),+ THFieldDef (..),+ THUniqueDef (..),+ THUniqueKeyDef (..),+ THAutoKeyDef (..),+ PSEntityDef (..),+ PSEmbeddedDef (..),+ PSPrimitiveDef (..),+ PSConstructorDef (..),+ PSFieldDef (..),+ PSUniqueDef (..),+ PSUniqueKeyDef (..),+ PSAutoKeyDef (..),+ )+where++import Control.Applicative+import Control.Monad (forM, mzero, when)+import Data.Aeson+import Data.Aeson.Types (Pair)+import qualified Data.Foldable as Fold+import qualified Data.HashMap.Strict as H+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Database.Groundhog.Core (ReferenceActionType (..), UniqueType (..))+import Database.Groundhog.Generic (PSFieldDef (..))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift (..))++data PersistDefinitions = PersistDefinitions {psEntities :: [PSEntityDef], psEmbeddeds :: [PSEmbeddedDef], psPrimitives :: [PSPrimitiveDef]}+ deriving (Show, Lift)++-- data SomeData a = U1 { foo :: Int} | U2 { bar :: Maybe String, asc :: Int64, add :: a} | U3 deriving (Show, Eq)++data THEntityDef = THEntityDef+ { thDataName :: Name, -- SomeData+ thDbEntityName :: String, -- SQLSomeData+ thEntitySchema :: Maybe String,+ thAutoKey :: Maybe THAutoKeyDef,+ thUniqueKeys :: [THUniqueKeyDef],+#if MIN_VERSION_template_haskell(2, 17, 0)+ thTypeParams :: [TyVarBndr ()],+#else+ thTypeParams :: [TyVarBndr],+#endif+ thConstructors :: [THConstructorDef]+ }+ deriving (Eq, Show)++data THAutoKeyDef = THAutoKeyDef+ { thAutoKeyConstrName :: String,+ thAutoKeyIsDef :: Bool+ }+ deriving (Eq, Show)++data THEmbeddedDef = THEmbeddedDef+ { thEmbeddedName :: Name,+ thEmbeddedConstructorName :: Name,+ -- | It is used only to set polymorphic part of name of its container+ thDbEmbeddedName :: String,+#if MIN_VERSION_template_haskell(2, 17, 0)+ thEmbeddedTypeParams :: [TyVarBndr ()],+#else+ thEmbeddedTypeParams :: [TyVarBndr],+#endif+ thEmbeddedFields :: [THFieldDef]+ }+ deriving (Eq, Show)++data THPrimitiveDef = THPrimitiveDef+ { thPrimitiveName :: Name,+ -- | It is used only to set polymorphic part of name of its container+ thPrimitiveDbName :: String,+ -- | Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`+ thPrimitiveConverter :: Name+ }+ deriving (Eq, Show)++data THConstructorDef = THConstructorDef+ { thConstrName :: Name, -- U2+ thPhantomConstrName :: String, -- U2Constructor+ thDbConstrName :: String, -- SQLU2+ thDbAutoKeyName :: Maybe String, -- u2_id+ thConstrFields :: [THFieldDef],+ thConstrUniques :: [THUniqueDef]+ }+ deriving (Eq, Show)++data THFieldDef = THFieldDef+ { -- | name in the record, bar+ thFieldName :: String,+ -- | column name, SQLbar+ thDbFieldName :: String,+ -- | column type, inet, NUMERIC(5, 2), VARCHAR(50), etc.+ thDbTypeName :: Maybe String,+ -- | name of constructor in the Field GADT, BarField+ thExprName :: String,+ thFieldType :: Type,+ thEmbeddedDef :: Maybe [PSFieldDef String],+ -- | default value in the database+ thDefaultValue :: Maybe String,+ thReferenceParent :: Maybe (Maybe ((Maybe String, String), [String]), Maybe ReferenceActionType, Maybe ReferenceActionType),+ -- | name of a pair of functions+ thFieldConverter :: Maybe Name+ }+ deriving (Eq, Show)++data THUniqueDef = THUniqueDef+ { thUniqueName :: String,+ thUniqueType :: UniqueType,+ -- | Either name of field, i.e, thFieldName, or expression+ thUniqueFields :: [Either String String]+ }+ deriving (Eq, Show)++data THUniqueKeyDef = THUniqueKeyDef+ { thUniqueKeyName :: String,+ thUniqueKeyPhantomName :: String,+ thUniqueKeyConstrName :: String,+ -- | It is used only to set polymorphic part of name of its container+ -- | It should repeat fields from THUniqueDef but it may give different settings for them. It is done to allow foreign key fields to be different from parent fields of the entity. These fields are used for creating a the key constructor and instances for it. For example, it can have a default value, or even a different type (INT8 may reference INT4).+ thUniqueKeyDbName :: String,+ thUniqueKeyFields :: [THFieldDef],+ -- | If True, make it an instance of Embedded+ thUniqueKeyMakeEmbedded :: Bool,+ thUniqueKeyIsDef :: Bool+ }+ deriving (Eq, Show)++data PSEntityDef = PSEntityDef+ { psDataName :: String, -- SomeData+ psDbEntityName :: Maybe String, -- SQLSomeData+ psEntitySchema :: Maybe String,+ psAutoKey :: Maybe (Maybe PSAutoKeyDef), -- SomeDataKey. Nothing - default key. Just Nothing - no autokey. Just (Just _) - specify autokey settings+ psUniqueKeys :: Maybe [PSUniqueKeyDef],+ psConstructors :: Maybe [PSConstructorDef]+ }+ deriving (Eq, Show, Lift)++data PSEmbeddedDef = PSEmbeddedDef+ { psEmbeddedName :: String,+ -- | It is used only to set polymorphic part of name of its container+ psDbEmbeddedName :: Maybe String,+ psEmbeddedFields :: Maybe [PSFieldDef String]+ }+ deriving (Eq, Show, Lift)++data PSPrimitiveDef = PSPrimitiveDef+ { psPrimitiveName :: String,+ -- | It is used only to set polymorphic part of name of its container+ psPrimitiveDbName :: Maybe String,+ -- | Name of a pair of functions converting the value to and from a type that is an instance of `PrimitivePersistField`+ psPrimitiveConverter :: String+ }+ deriving (Eq, Show, Lift)++data PSConstructorDef = PSConstructorDef+ { psConstrName :: String, -- U2+ psPhantomConstrName :: Maybe String, -- U2Constructor+ psDbConstrName :: Maybe String, -- SQLU2+ psDbAutoKeyName :: Maybe String, -- u2_id+ psConstrFields :: Maybe [PSFieldDef String],+ psConstrUniques :: Maybe [PSUniqueDef]+ }+ deriving (Eq, Show, Lift)++data PSUniqueDef = PSUniqueDef+ { psUniqueName :: String,+ psUniqueType :: Maybe UniqueType,+ psUniqueFields :: [Either String String]+ }+ deriving (Eq, Show, Lift)++data PSUniqueKeyDef = PSUniqueKeyDef+ { psUniqueKeyName :: String,+ psUniqueKeyPhantomName :: Maybe String,+ psUniqueKeyConstrName :: Maybe String,+ psUniqueKeyDbName :: Maybe String,+ psUniqueKeyFields :: Maybe [PSFieldDef String],+ psUniqueKeyMakeEmbedded :: Maybe Bool,+ psUniqueKeyIsDef :: Maybe Bool+ }+ deriving (Eq, Show, Lift)++data PSAutoKeyDef = PSAutoKeyDef+ { psAutoKeyConstrName :: Maybe String,+ psAutoKeyIsDef :: Maybe Bool+ }+ deriving (Eq, Show, Lift)++deriving instance Lift a => Lift (PSFieldDef a)++deriving instance Lift UniqueType++deriving instance Lift ReferenceActionType++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 =+ case value of+ Object v -> do+ defs <- v .:? "definitions"+ case defs of+ Just (Array arr) -> Fold.foldrM go initial arr+ Nothing -> go value initial+ Just _ -> mzero+ Array arr -> Fold.foldrM go initial arr+ _ -> mzero+ where+ initial = PersistDefinitions [] [] []+ go obj p@PersistDefinitions {..} = flip (withObject "definition") obj $ \v -> case () of+ _ | H.member "entity" v -> (\x -> p {psEntities = x : psEntities}) <$> parseJSON obj+ _ | H.member "embedded" v -> (\x -> p {psEmbeddeds = x : psEmbeddeds}) <$> parseJSON obj+ _ | H.member "primitive" v -> (\x -> p {psPrimitives = x : psPrimitives}) <$> parseJSON obj+ _ -> fail $ "Invalid definition: " ++ show obj++instance FromJSON PSEntityDef where+ parseJSON = withObject "entity" $ \v ->+ PSEntityDef <$> v .: "entity" <*> v .:? "dbName" <*> v .:? "schema" <*> optional (v .: "autoKey") <*> v .:? "keys" <*> v .:? "constructors"++instance FromJSON PSEmbeddedDef where+ parseJSON = withObject "embedded" $ \v ->+ PSEmbeddedDef <$> v .: "embedded" <*> v .:? "dbName" <*> v .:? "fields"++instance FromJSON PSPrimitiveDef where+ parseJSON = withObject "primitive" $ \v -> do+ when (H.member "representation" v) $ fail $ "parseJSON: field 'representation' is deprecated. Use 'converter' instead: " ++ show v+ PSPrimitiveDef <$> v .: "primitive" <*> v .:? "dbName" <*> v .: "converter"++instance FromJSON PSConstructorDef where+ parseJSON = withObject "constructor" $ \v ->+ PSConstructorDef <$> v .: "name" <*> v .:? "phantomName" <*> v .:? "dbName" <*> v .:? "keyDbName" <*> v .:? "fields" <*> v .:? "uniques"++instance FromJSON PSUniqueDef where+ parseJSON = withObject "unique" $ \v -> do+ fields <- v .: "fields"+ fields' <- forM fields $ \case+ Object expr -> Right <$> expr .: "expr"+ field -> Left <$> parseJSON field+ PSUniqueDef <$> v .: "name" <*> v .:? "type" <*> pure fields'++instance FromJSON UniqueType where+ parseJSON o = do+ x <- parseJSON o+ let vals = [("constraint", UniqueConstraint), ("index", UniqueIndex), ("primary", UniquePrimary False)]+ case lookup x vals of+ Just a -> pure a+ Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x++instance FromJSON ReferenceActionType where+ parseJSON o = do+ x <- parseJSON o+ let vals = [("no action", NoAction), ("restrict", Restrict), ("cascade", Cascade), ("set null", SetNull), ("set default", SetDefault)]+ case lookup x vals of+ Just a -> pure a+ Nothing -> fail $ "parseJSON: UniqueType expected " ++ show (map fst vals) ++ ", but got " ++ x++instance FromJSON (PSFieldDef String) where+ parseJSON = withObject "field" $ \v ->+ PSFieldDef <$> v .: "name" <*> v .:? "dbName" <*> v .:? "type" <*> v .:? "exprName" <*> v .:? "embeddedType" <*> v .:? "default" <*> mkRefSettings v <*> v .:? "converter"+ where+ mkRefSettings v = do+ ref <- v .:? "reference"+ (parent, onDel, onUpd) <- case ref of+ Just (Object r) -> (,,) <$> optional parentRef <*> r .:? "onDelete" <*> r .:? "onUpdate"+ where+ parentRef = (,) <$> ((,) <$> r .:? "schema" <*> r .: "table") <*> r .: "columns"+ _ -> pure (Nothing, Nothing, Nothing)+ -- this temporary solution uses onDelete and onUpdate both from inside reference object (preferred) and from field level (for compatibility)+ (onDel', onUpd') <- (,) <$> v .:? "onDelete" <*> v .:? "onUpdate"+ pure $ case (parent, onDel <|> onDel', onUpd <|> onUpd') of+ (Nothing, Nothing, Nothing) -> Nothing+ refSettings -> Just refSettings++instance FromJSON PSUniqueKeyDef where+ parseJSON = withObject "unique key" $ \v ->+ PSUniqueKeyDef <$> v .: "name" <*> v .:? "keyPhantom" <*> v .:? "constrName" <*> v .:? "dbName" <*> v .:? "fields" <*> v .:? "mkEmbedded" <*> v .:? "default"++instance FromJSON PSAutoKeyDef where+ parseJSON = withObject "autogenerated key" $ \v ->+ PSAutoKeyDef <$> v .:? "constrName" <*> v .:? "default"++(.=?) :: ToJSON a => Text -> Maybe a -> Maybe Pair+name .=? value = (name .=) <$> value++(.=:) :: ToJSON a => Text -> Maybe [a] -> Maybe Pair+name .=: value = case value of+ Just (_ : _) -> Just $ name .= value+ _ -> Nothing++instance ToJSON PSEntityDef where+ toJSON PSEntityDef {..} = object $ catMaybes [Just $ "entity" .= psDataName, "dbName" .=? psDbEntityName, "schema" .=? psEntitySchema, "autoKey" .=? psAutoKey, "keys" .=: psUniqueKeys, "constructors" .=: psConstructors]++instance ToJSON PSConstructorDef where+ toJSON PSConstructorDef {..} = object $ catMaybes [Just $ "name" .= psConstrName, "phantomName" .=? psPhantomConstrName, "dbName" .=? psDbConstrName, "keyDbName" .=? psDbAutoKeyName, "fields" .=: psConstrFields, "uniques" .=: psConstrUniques]++instance ToJSON PSUniqueDef where+ toJSON PSUniqueDef {..} = object $ catMaybes [Just $ "name" .= psUniqueName, "type" .=? psUniqueType, "fields" .=? fields]+ where+ fields =+ if null psUniqueFields+ then Nothing+ else Just $ map (either toJSON (\x -> object ["expr" .= x])) psUniqueFields++instance ToJSON UniqueType where+ toJSON a = toJSON $ case a of+ UniqueConstraint -> "constraint" :: String+ UniqueIndex -> "index"+ UniquePrimary _ -> "primary"++instance ToJSON ReferenceActionType where+ toJSON a = toJSON $ case a of+ NoAction -> "no action" :: String+ Restrict -> "restrict"+ Cascade -> "cascade"+ SetNull -> "set null"+ SetDefault -> "set default"++instance ToJSON (PSFieldDef String) where+ toJSON PSFieldDef {..} = object $ catMaybes [Just $ "name" .= psFieldName, "dbName" .=? psDbFieldName, "type" .=? psDbTypeName, "exprName" .=? psExprName, "embeddedType" .=: psEmbeddedDef, "default" .=? psDefaultValue, "reference" .=? (psReferenceParent >>= mkRefSettings)]+ where+ mkRefSettings (parent, onDel, onUpd) = if null fields then Nothing else Just $ object fields+ where+ fields = catMaybes $ parent' ++ ["onDelete" .=? onDel, "onUpdate" .=? onUpd]+ parent' = case parent of+ Nothing -> []+ Just ((schema, table), columns) -> ["schema" .=? schema, Just $ "table" .= table, Just $ "columns" .= columns]++instance ToJSON PSUniqueKeyDef where+ toJSON PSUniqueKeyDef {..} = object $ catMaybes [Just $ "name" .= psUniqueKeyName, "keyPhantom" .=? psUniqueKeyPhantomName, "constrName" .=? psUniqueKeyConstrName, "dbName" .=? psUniqueKeyDbName, "mkEmbedded" .=? psUniqueKeyMakeEmbedded, "default" .=? psUniqueKeyIsDef, "fields" .=: psUniqueKeyFields]++instance ToJSON PSAutoKeyDef where+ toJSON PSAutoKeyDef {..} = object $ catMaybes ["constrName" .=? psAutoKeyConstrName, "default" .=? psAutoKeyIsDef]
groundhog-th.cabal view
@@ -1,5 +1,5 @@ name: groundhog-th-version: 0.11+version: 0.12 license: BSD3 license-file: LICENSE author: Boris Lykah <lykahb@gmail.com>@@ -8,7 +8,7 @@ description: This library helps to generate instances for Groundhog datatypes. category: Database stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple extra-source-files:@@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5 , bytestring >= 0.9- , groundhog >= 0.11 && < 0.12+ , groundhog >= 0.11 && < 0.13 , template-haskell , time >= 1.1.4 , containers >= 0.2@@ -30,6 +30,8 @@ Database.Groundhog.TH.Settings Database.Groundhog.TH.CodeGen ghc-options: -Wall+ default-language: Haskell2010+ source-repository head type: git