diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # Changelog for persistent +# 2.15.0.0 + +* [#1569](https://github.com/yesodweb/persistent/pull/1569) + * Add position information to `EntityDef`, `UnboundEntityDef` via a `Span` + field as a preliminary design that just gives the entire span of the + input text (i.e. the entire file or quasiquote the item is defined in). + * Move `Database.Persist.TH` internals to `Database.Persist.TH.Internal` and + no longer export the following internals: + * lensPTH + * parseReferences + * embedEntityDefs + * fieldError + * AtLeastOneUniqueKey(..) + * OnlyOneUniqueKey(..) + * pkNewtype + ## 2.14.6.3 * [#1544](https://github.com/yesodweb/persistent/pull/1544) diff --git a/Database/Persist/EntityDef.hs b/Database/Persist/EntityDef.hs --- a/Database/Persist/EntityDef.hs +++ b/Database/Persist/EntityDef.hs @@ -19,6 +19,7 @@ , getEntityKeyFields , getEntityComments , getEntityExtra + , getEntitySpan , isEntitySum , entityPrimary , entitiesPrimary @@ -40,7 +41,8 @@ import Database.Persist.FieldDef import Database.Persist.Names -import Database.Persist.Types.Base (ForeignDef, UniqueDef(..), entityKeyFields) +import Database.Persist.Types.Base + (ForeignDef, Span, UniqueDef(..), entityKeyFields) -- | Retrieve the list of 'UniqueDef' from an 'EntityDef'. This does not include -- a @Primary@ key, if one is defined. A future version of @persistent@ will @@ -205,3 +207,13 @@ -> EntityDef overEntityFields f ed = setEntityFields (f (getEntityFieldsDatabase ed)) ed + +-- | Gets the 'Span' of the definition of the entity. +-- +-- Note that as of this writing the span covers the entire file or quasiquote +-- where the item is defined due to parsing limitations. This may be changed in +-- a future release to be more accurate. +-- +-- @since 2.15.0.0 +getEntitySpan :: EntityDef -> Maybe Span +getEntitySpan = entitySpan diff --git a/Database/Persist/Quasi/Internal.hs b/Database/Persist/Quasi/Internal.hs --- a/Database/Persist/Quasi/Internal.hs +++ b/Database/Persist/Quasi/Internal.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -21,6 +22,8 @@ , toFKNameInfixed , Token (..) , Line (..) + , SourceLoc(..) + , sourceLocFromTHLoc , preparse , parseLine , parseFieldType @@ -66,7 +69,7 @@ import Database.Persist.EntityDef.Internal import Database.Persist.Types import Database.Persist.Types.Base -import Language.Haskell.TH.Syntax (Lift) +import Language.Haskell.TH.Syntax (Lift, Loc(..)) import qualified Text.Read as R data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show @@ -205,14 +208,48 @@ toFKNameInfixed inf (EntityNameHS entName) (ConstraintNameHS conName) = entName <> inf <> conName +-- | Source location: file and line/col information. This is half of a 'Span'. +data SourceLoc = SourceLoc + { locFile :: Text + , locStartLine :: Int + , locStartCol :: Int + } deriving (Show, Lift) + +sourceLocFromTHLoc :: Loc -> SourceLoc +sourceLocFromTHLoc Loc {loc_filename=filename, loc_start=start} = + SourceLoc {locFile = T.pack filename, locStartLine = fst start, locStartCol = snd start} + + -- | Parses a quasi-quoted syntax into a list of entity definitions. -parse :: PersistSettings -> Text -> [UnboundEntityDef] -parse ps = maybe [] (parseLines ps) . preparse +parse :: PersistSettings -> [(Maybe SourceLoc, Text)] -> [UnboundEntityDef] +parse ps blocks = + mconcat $ handleBlock <$> blocks + where + handleBlock (mLoc, block) = + maybe [] + (\(numLines, lns) -> parseLines ps (approximateSpan numLines block <$> mLoc) lns) + (preparse block) + -- FIXME: put an actually truthful span into here + -- We can't give a better result if we push any of this down into the + -- parser at the moment since the parser throws out location info by + -- e.g. discarding comment lines completely without keeping track of + -- where it is. The realistic fix to this is rewriting the parser in + -- Megaparsec, which is a reasonable idea that should actually be done. + approximateSpan numLines block loc = + Span + { spanFile = locFile loc + , spanStartLine = locStartLine loc + , spanStartCol = locStartCol loc + , spanEndLine = locStartLine loc + numLines - 1 + -- Last line's length plus one (since we are one-past-the-end) + , spanEndCol = (+ 1) . T.length . T.takeWhileEnd (/= '\n') $ block + } -preparse :: Text -> Maybe (NonEmpty Line) +preparse :: Text -> Maybe (Int, NonEmpty Line) preparse txt = do lns <- NEL.nonEmpty (T.lines txt) - NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) + let rawLineCount = length lns + (rawLineCount,) <$> NEL.nonEmpty (mapMaybe parseLine (NEL.toList lns)) parseLine :: Text -> Maybe Line parseLine txt = do @@ -303,9 +340,9 @@ lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions. -parseLines :: PersistSettings -> NonEmpty Line -> [UnboundEntityDef] -parseLines ps = do - fmap (mkUnboundEntityDef ps . toParsedEntityDef) . associateLines +parseLines :: PersistSettings -> Maybe Span -> NonEmpty Line -> [UnboundEntityDef] +parseLines ps mSpan = do + fmap (mkUnboundEntityDef ps . toParsedEntityDef mSpan) . associateLines data ParsedEntityDef = ParsedEntityDef { parsedEntityDefComments :: [Text] @@ -314,6 +351,7 @@ , parsedEntityDefEntityAttributes :: [Attr] , parsedEntityDefFieldAttributes :: [[Token]] , parsedEntityDefExtras :: M.Map Text [ExtraLine] + , parsedEntityDefSpan :: Maybe Span } entityNamesFromParsedDef :: PersistSettings -> ParsedEntityDef -> (EntityNameHS, EntityNameDB) @@ -325,14 +363,15 @@ entNameDB = EntityNameDB $ getDbName ps (unEntityNameHS entNameHS) (parsedEntityDefEntityAttributes parsedEntDef) -toParsedEntityDef :: LinesWithComments -> ParsedEntityDef -toParsedEntityDef lwc = ParsedEntityDef +toParsedEntityDef :: Maybe Span -> LinesWithComments -> ParsedEntityDef +toParsedEntityDef mSpan lwc = ParsedEntityDef { parsedEntityDefComments = lwcComments lwc , parsedEntityDefEntityName = entNameHS , parsedEntityDefIsSum = isSum , parsedEntityDefEntityAttributes = entAttribs , parsedEntityDefFieldAttributes = attribs , parsedEntityDefExtras = extras + , parsedEntityDefSpan = mSpan } where entityLine :| fieldLines = @@ -458,6 +497,10 @@ -- the field?" yet, so we defer those to the Template Haskell execution. -- -- @since 2.13.0.0 + , unboundEntityDefSpan :: Maybe Span + -- ^ The source code span of this entity in the models file. + -- + -- @since 2.15.0.0 } deriving (Eq, Ord, Show, Lift) @@ -481,6 +524,7 @@ ed , unboundEntityFields = map unbindFieldDef (entityFields ed) + , unboundEntityDefSpan = entitySpan ed } -- | Returns the @['UnboundFieldDef']@ for an 'UnboundEntityDef'. This returns @@ -689,6 +733,7 @@ DefaultKey (FieldNameDB $ psIdName ps) , unboundEntityFields = cols + , unboundEntityDefSpan = parsedEntityDefSpan parsedEntDef , unboundEntityDef = EntityDef { entityHaskell = entNameHS @@ -712,6 +757,7 @@ case parsedEntityDefComments parsedEntDef of [] -> Nothing comments -> Just (T.unlines comments) + , entitySpan = parsedEntityDefSpan parsedEntDef } } where diff --git a/Database/Persist/SqlBackend/Internal/IsolationLevel.hs b/Database/Persist/SqlBackend/Internal/IsolationLevel.hs --- a/Database/Persist/SqlBackend/Internal/IsolationLevel.hs +++ b/Database/Persist/SqlBackend/Internal/IsolationLevel.hs @@ -3,7 +3,7 @@ import Data.String (IsString(..)) -- | Please refer to the documentation for the database in question for a full --- overview of the semantics of the varying isloation levels +-- overview of the semantics of the varying isolation levels data IsolationLevel = ReadUncommitted | ReadCommitted | RepeatableRead diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -1,3427 +1,49 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | This module provides the tools for defining your database schema and using --- it to generate Haskell data types and migrations. --- --- For documentation on the domain specific language used for defining database --- models, see "Database.Persist.Quasi". --- --- -module Database.Persist.TH - ( -- * Parse entity defs - persistWith - , persistUpperCase - , persistLowerCase - , persistFileWith - , persistManyFileWith - -- * Turn @EntityDef@s into types - , mkPersist - , mkPersistWith - -- ** Configuring Entity Definition - , MkPersistSettings - , mkPersistSettings - , sqlSettings - -- *** Record Fields (for update/viewing settings) - , mpsBackend - , mpsGeneric - , mpsPrefixFields - , mpsFieldLabelModifier - , mpsAvoidHsKeyword - , mpsConstraintLabelModifier - , mpsEntityHaddocks - , mpsEntityJSON - , mpsGenerateLenses - , mpsDeriveInstances - , mpsCamelCaseCompositeKeySelector - , EntityJSON(..) - -- ** Implicit ID Columns - , ImplicitIdDef - , setImplicitIdDef - -- * Various other TH functions - , mkMigrate - , migrateModels - , discoverEntities - , mkEntityDefList - , share - , derivePersistField - , derivePersistFieldJSON - , persistFieldFromEntity - -- * Internal - , lensPTH - , parseReferences - , embedEntityDefs - , fieldError - , AtLeastOneUniqueKey(..) - , OnlyOneUniqueKey(..) - , pkNewtype - ) where - --- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code --- It's highly recommended to check the diff between master and your PR's generated code. - -import Prelude hiding (concat, exp, splitAt, take, (++)) - -import Control.Monad -import Data.Aeson - ( FromJSON(..) - , ToJSON(..) - , eitherDecodeStrict' - , object - , withObject - , (.:) - , (.:?) - , (.=) - ) -#if MIN_VERSION_aeson(2,0,0) -import qualified Data.Aeson.Key as Key -#endif -import qualified Data.ByteString as BS -import Data.Char (toLower, toUpper) -import Data.Coerce -import Data.Data (Data) -import Data.Either -import qualified Data.HashMap.Strict as HM -import Data.Int (Int64) -import Data.Ix (Ix) -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) -import Data.Proxy (Proxy(Proxy)) -import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import qualified Data.Text.Encoding as TE -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import GHC.TypeLits -import Instances.TH.Lift () - -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` - -- instance on pre-1.2.4 versions of `text` -import Data.Foldable (asum, toList) -import qualified Data.Set as Set -import Language.Haskell.TH.Lib - (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) -#if MIN_VERSION_template_haskell(2,21,0) -import Language.Haskell.TH.Lib (defaultBndrFlag) -#endif -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) -import Web.PathPieces (PathPiece(..)) - -import Database.Persist -import Database.Persist.Class.PersistEntity -import Database.Persist.Quasi -import Database.Persist.Quasi.Internal -import Database.Persist.Sql - (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) - -import Database.Persist.EntityDef.Internal (EntityDef(..)) -import Database.Persist.ImplicitIdDef (autoIncrementingInteger) -import Database.Persist.ImplicitIdDef.Internal - -#if MIN_VERSION_template_haskell(2,18,0) -conp :: Name -> [Pat] -> Pat -conp name pats = ConP name [] pats -#else -conp :: Name -> [Pat] -> Pat -conp = ConP -#endif - --- | Converts a quasi-quoted syntax into a list of entity definitions, to be --- used as input to the template haskell generation code (mkPersist). -persistWith :: PersistSettings -> QuasiQuoter -persistWith ps = QuasiQuoter - { quoteExp = - parseReferences ps . pack - , quotePat = - error "persistWith can't be used as pattern" - , quoteType = - error "persistWith can't be used as type" - , quoteDec = - error "persistWith can't be used as declaration" - } - --- | Apply 'persistWith' to 'upperCaseSettings'. -persistUpperCase :: QuasiQuoter -persistUpperCase = persistWith upperCaseSettings - --- | Apply 'persistWith' to 'lowerCaseSettings'. -persistLowerCase :: QuasiQuoter -persistLowerCase = persistWith lowerCaseSettings - --- | Same as 'persistWith', but uses an external file instead of a --- quasiquotation. The recommended file extension is @.persistentmodels@. -persistFileWith :: PersistSettings -> FilePath -> Q Exp -persistFileWith ps fp = persistManyFileWith ps [fp] - --- | Same as 'persistFileWith', but uses several external files instead of --- one. Splitting your Persistent definitions into multiple modules can --- potentially dramatically speed up compile times. --- --- The recommended file extension is @.persistentmodels@. --- --- ==== __Examples__ --- --- Split your Persistent definitions into multiple files (@models1@, @models2@), --- then create a new module for each new file and run 'mkPersist' there: --- --- @ --- -- Model1.hs --- 'share' --- ['mkPersist' 'sqlSettings'] --- $('persistFileWith' 'lowerCaseSettings' "models1") --- @ --- @ --- -- Model2.hs --- 'share' --- ['mkPersist' 'sqlSettings'] --- $('persistFileWith' 'lowerCaseSettings' "models2") --- @ --- --- Use 'persistManyFileWith' to create your migrations: --- --- @ --- -- Migrate.hs --- 'mkMigrate' "migrateAll" --- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) --- @ --- --- Tip: To get the same import behavior as if you were declaring all your models in --- one file, import your new files @as Name@ into another file, then export @module Name@. --- --- This approach may be used in the future to reduce memory usage during compilation, --- but so far we've only seen mild reductions. --- --- See and --- for more details. --- --- @since 2.5.4 -persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp -persistManyFileWith ps fps = do - mapM_ qAddDependentFile fps - ss <- mapM (qRunIO . getFileContents) fps - let s = T.intercalate "\n" ss -- be tolerant of the user forgetting to put a line-break at EOF. - parseReferences ps s - -getFileContents :: FilePath -> IO Text -getFileContents = fmap decodeUtf8 . BS.readFile - --- | Takes a list of (potentially) independently defined entities and properly --- links all foreign keys to reference the right 'EntityDef', tying the knot --- between entities. --- --- Allows users to define entities indepedently or in separate modules and then --- fix the cross-references between them at runtime to create a 'Migration'. --- --- @since 2.7.2 -embedEntityDefs - :: [EntityDef] - -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' - -- call. - -- - -- @since 2.13.0.0 - -> [UnboundEntityDef] - -> [UnboundEntityDef] -embedEntityDefs eds = snd . embedEntityDefsMap eds - -embedEntityDefsMap - :: [EntityDef] - -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' - -- call. - -- - -- @since 2.13.0.0 - -> [UnboundEntityDef] - -> (EmbedEntityMap, [UnboundEntityDef]) -embedEntityDefsMap existingEnts rawEnts = - (embedEntityMap, noCycleEnts) - where - noCycleEnts = entsWithEmbeds - embedEntityMap = constructEmbedEntityMap entsWithEmbeds - entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts) - setEmbedEntity ubEnt = - let - ent = unboundEntityDef ubEnt - in - ubEnt - { unboundEntityDef = - overEntityFields - (fmap (setEmbedField (entityHaskell ent) embedEntityMap)) - ent - } - - --- | Calls 'parse' to Quasi.parse individual entities in isolation --- afterwards, sets references to other entities --- --- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@ --- instead of @['EntityDef']@. --- --- @since 2.5.3 -parseReferences :: PersistSettings -> Text -> Q Exp -parseReferences ps s = lift $ parse ps s - -preprocessUnboundDefs - :: [EntityDef] - -> [UnboundEntityDef] - -> (M.Map EntityNameHS (), [UnboundEntityDef]) -preprocessUnboundDefs preexistingEntities unboundDefs = - (embedEntityMap, noCycleEnts) - where - (embedEntityMap, noCycleEnts) = - embedEntityDefsMap preexistingEntities unboundDefs - -liftAndFixKeys - :: MkPersistSettings - -> M.Map EntityNameHS a - -> EntityMap - -> UnboundEntityDef - -> Q Exp -liftAndFixKeys mps emEntities entityMap unboundEnt = - let - ent = - unboundEntityDef unboundEnt - fields = - getUnboundFieldDefs unboundEnt - in - [| - ent - { entityFields = - $(ListE <$> traverse combinedFixFieldDef fields) - , entityId = - $(fixPrimarySpec mps unboundEnt) - , entityForeigns = - $(fixUnboundForeignDefs (unboundForeignDefs unboundEnt)) - } - |] - where - fixUnboundForeignDefs - :: [UnboundForeignDef] - -> Q Exp - fixUnboundForeignDefs fdefs = - fmap ListE $ forM fdefs fixUnboundForeignDef - where - fixUnboundForeignDef UnboundForeignDef{..} = - [| - unboundForeignDef - { foreignFields = - $(lift fixForeignFields) - , foreignNullable = - $(lift fixForeignNullable) - , foreignRefTableDBName = - $(lift fixForeignRefTableDBName) - } - |] - where - fixForeignRefTableDBName = - entityDB (unboundEntityDef parentDef) - foreignFieldNames = - case unboundForeignFields of - FieldListImpliedId ffns -> - ffns - FieldListHasReferences references -> - fmap ffrSourceField references - parentDef = - case M.lookup parentTableName entityMap of - Nothing -> - error $ mconcat - [ "Foreign table not defined: " - , show parentTableName - ] - Just a -> - a - parentTableName = - foreignRefTableHaskell unboundForeignDef - fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)] - fixForeignFields = - case unboundForeignFields of - FieldListImpliedId ffns -> - mkReferences $ toList ffns - FieldListHasReferences references -> - toList $ fmap convReferences references - where - -- in this case, we're up against the implied ID of the parent - -- dodgy assumption: columns are listed in the right order. we - -- can't check this any more clearly right now. - mkReferences fieldNames - | length fieldNames /= length parentKeyFieldNames = - error $ mconcat - [ "Foreign reference needs to have the same number " - , "of fields as the target table." - , "\n Table : " - , show (getUnboundEntityNameHS unboundEnt) - , "\n Foreign Table: " - , show parentTableName - , "\n Fields : " - , show fieldNames - , "\n Parent fields: " - , show (fmap fst parentKeyFieldNames) - , "\n\nYou can use the References keyword to fix this." - ] - | otherwise = - zip (fmap (withDbName fieldStore) fieldNames) (toList parentKeyFieldNames) - where - parentKeyFieldNames - :: NonEmpty (FieldNameHS, FieldNameDB) - parentKeyFieldNames = - case unboundPrimarySpec parentDef of - NaturalKey ucd -> - fmap (withDbName parentFieldStore) (unboundCompositeCols ucd) - SurrogateKey uid -> - pure (FieldNameHS "Id", unboundIdDBName uid) - DefaultKey dbName -> - pure (FieldNameHS "Id", dbName) - withDbName store fieldNameHS = - ( fieldNameHS - , findDBName store fieldNameHS - ) - convReferences - :: ForeignFieldReference - -> (ForeignFieldDef, ForeignFieldDef) - convReferences ForeignFieldReference {..} = - ( withDbName fieldStore ffrSourceField - , withDbName parentFieldStore ffrTargetField - ) - fixForeignNullable = - all ((NotNullable /=) . isForeignNullable) foreignFieldNames - where - isForeignNullable fieldNameHS = - case getFieldDef fieldNameHS fieldStore of - Nothing -> - error "Field name not present in map" - Just a -> - isUnboundFieldNullable a - - fieldStore = - mkFieldStore unboundEnt - parentFieldStore = - mkFieldStore parentDef - findDBName store fieldNameHS = - case getFieldDBName fieldNameHS store of - Nothing -> - error $ mconcat - [ "findDBName: failed to fix dbname for: " - , show fieldNameHS - ] - Just a-> - a - - combinedFixFieldDef :: UnboundFieldDef -> Q Exp - combinedFixFieldDef ufd@UnboundFieldDef{..} = - [| - FieldDef - { fieldHaskell = - unboundFieldNameHS - , fieldDB = - unboundFieldNameDB - , fieldType = - unboundFieldType - , fieldSqlType = - $(sqlTyp') - , fieldAttrs = - unboundFieldAttrs - , fieldStrict = - unboundFieldStrict - , fieldReference = - $(fieldRef') - , fieldCascade = - unboundFieldCascade - , fieldComments = - unboundFieldComments - , fieldGenerated = - unboundFieldGenerated - , fieldIsImplicitIdColumn = - False - } - |] - where - sqlTypeExp = - getSqlType emEntities entityMap ufd - FieldDef _x _ _ _ _ _ _ _ _ _ _ = - error "need to update this record wildcard match" - (fieldRef', sqlTyp') = - case extractForeignRef entityMap ufd of - Just targetTable -> - let targetTableQualified = - fromMaybe targetTable (guessFieldReferenceQualified ufd) - in (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTableQualified)) - Nothing -> - (lift NoReference, liftSqlTypeExp sqlTypeExp) - -data FieldStore - = FieldStore - { fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef - , fieldStoreId :: Maybe FieldNameDB - , fieldStoreEntity :: UnboundEntityDef - } - -mkFieldStore :: UnboundEntityDef -> FieldStore -mkFieldStore ued = - FieldStore - { fieldStoreEntity = ued - , fieldStoreMap = - M.fromList - $ fmap (\ufd -> - ( unboundFieldNameHS ufd - , ufd - ) - ) - $ getUnboundFieldDefs - $ ued - , fieldStoreId = - case unboundPrimarySpec ued of - NaturalKey _ -> - Nothing - SurrogateKey fd -> - Just $ unboundIdDBName fd - DefaultKey n -> - Just n - } - -getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB -getFieldDBName name fs - | FieldNameHS "Id" == name = - fieldStoreId fs - | otherwise = - unboundFieldNameDB <$> getFieldDef name fs - -getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef -getFieldDef fieldNameHS fs = - M.lookup fieldNameHS (fieldStoreMap fs) - -extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS -extractForeignRef entityMap fieldDef = do - refName <- guessFieldReference fieldDef - ent <- M.lookup refName entityMap - pure $ entityHaskell $ unboundEntityDef ent - -guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS -guessFieldReference = guessReference . unboundFieldType - -guessReference :: FieldType -> Maybe EntityNameHS -guessReference ft = - EntityNameHS <$> guessReferenceText (Just ft) - where - checkIdSuffix = - T.stripSuffix "Id" - guessReferenceText mft = - asum - [ do - FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft - pure tableName - , do - FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft - pure tableName - , do - FTApp (FTTypeCon _ "Maybe") next <- mft - guessReferenceText (Just next) - ] - -guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS -guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType - -guessReferenceQualified :: FieldType -> Maybe EntityNameHS -guessReferenceQualified ft = - EntityNameHS <$> guessReferenceText (Just ft) - where - checkIdSuffix = - T.stripSuffix "Id" - guessReferenceText mft = - asum - [ do - FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft - -- handle qualified name. - pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod - , do - FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft - -- handle qualified name. - pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod - , do - FTApp (FTTypeCon _ "Maybe") next <- mft - guessReferenceText (Just next) - ] - -mkDefaultKey - :: MkPersistSettings - -> FieldNameDB - -> EntityNameHS - -> FieldDef -mkDefaultKey mps pk unboundHaskellName = - let - iid = - mpsImplicitIdDef mps - in - maybe id addFieldAttr (FieldAttrDefault <$> iidDefault iid) $ - maybe id addFieldAttr (FieldAttrMaxlen <$> iidMaxLen iid) $ - mkAutoIdField' pk unboundHaskellName (iidFieldSqlType iid) - -fixPrimarySpec - :: MkPersistSettings - -> UnboundEntityDef - -> Q Exp -fixPrimarySpec mps unboundEnt= do - case unboundPrimarySpec unboundEnt of - DefaultKey pk -> - lift $ EntityIdField $ - mkDefaultKey mps pk unboundHaskellName - SurrogateKey uid -> do - let - entNameHS = - getUnboundEntityNameHS unboundEnt - fieldTyp = - fromMaybe (mkKeyConType entNameHS) (unboundIdType uid) - [| - EntityIdField - FieldDef - { fieldHaskell = - FieldNameHS "Id" - , fieldDB = - $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid)) - , fieldType = - $(lift fieldTyp) - , fieldSqlType = - $( liftSqlTypeExp (SqlTypeExp fieldTyp) ) - , fieldStrict = - False - , fieldReference = - ForeignRef entNameHS - , fieldAttrs = - unboundIdAttrs uid - , fieldComments = - Nothing - , fieldCascade = unboundIdCascade uid - , fieldGenerated = Nothing - , fieldIsImplicitIdColumn = True - } - - |] - NaturalKey ucd -> - [| EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd) |] - where - unboundHaskellName = - getUnboundEntityNameHS unboundEnt - -bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp -bindCompositeDef ued ucd = do - fieldDefs <- - fmap ListE $ forM (toList $ unboundCompositeCols ucd) $ \col -> - mkLookupEntityField ued col - [| - CompositeDef - { compositeFields = - NEL.fromList $(pure fieldDefs) - , compositeAttrs = - $(lift $ unboundCompositeAttrs ucd) - } - |] - -getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp -getSqlType emEntities entityMap field = - maybe - (defaultSqlTypeExp emEntities entityMap field) - (SqlType' . SqlOther) - (listToMaybe $ mapMaybe attrSqlType $ unboundFieldAttrs field) - --- In the case of embedding, there won't be any datatype created yet. --- We just use SqlString, as the data will be serialized to JSON. -defaultSqlTypeExp :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp -defaultSqlTypeExp emEntities entityMap field = - case mEmbedded emEntities ftype of - Right _ -> - SqlType' SqlString - Left (Just (FTKeyCon ty)) -> - SqlTypeExp (FTTypeCon Nothing ty) - Left Nothing -> - case extractForeignRef entityMap field of - Just refName -> - case M.lookup refName entityMap of - Nothing -> - -- error $ mconcat - -- [ "Failed to find model: " - -- , show refName - -- , " in entity list: \n" - -- ] - -- <> (unlines $ map show $ M.keys $ entityMap) - -- going to assume that it's fine, will reify it out - -- right later anyway) - SqlTypeExp ftype - -- A ForeignRef is blindly set to an Int64 in setEmbedField - -- correct that now - Just _ -> - SqlTypeReference refName - _ -> - case ftype of - -- In the case of lists, we always serialize to a string - -- value (via JSON). - -- - -- Normally, this would be determined automatically by - -- SqlTypeExp. However, there's one corner case: if there's - -- a list of entity IDs, the datatype for the ID has not - -- yet been created, so the compiler will fail. This extra - -- clause works around this limitation. - FTList _ -> - SqlType' SqlString - _ -> - SqlTypeExp ftype - where - ftype = unboundFieldType field - -attrSqlType :: FieldAttr -> Maybe Text -attrSqlType = \case - FieldAttrSqltype x -> Just x - _ -> Nothing - -data SqlTypeExp - = SqlTypeExp FieldType - | SqlType' SqlType - | SqlTypeReference EntityNameHS - deriving Show - -liftSqlTypeExp :: SqlTypeExp -> Q Exp -liftSqlTypeExp ste = - case ste of - SqlType' t -> - lift t - SqlTypeExp ftype -> do - let - typ = ftToType ftype - mtyp = ConT ''Proxy `AppT` typ - typedNothing = SigE (ConE 'Proxy) mtyp - pure $ VarE 'sqlType `AppE` typedNothing - SqlTypeReference entNameHs -> do - let - entNameId :: Name - entNameId = - mkName $ T.unpack (unEntityNameHS entNameHs) <> "Id" - - [| sqlType (Proxy :: Proxy $(conT entNameId)) |] - - -type EmbedEntityMap = M.Map EntityNameHS () - -constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap -constructEmbedEntityMap = - M.fromList . fmap - (\ent -> - ( entityHaskell (unboundEntityDef ent) - -- , toEmbedEntityDef (unboundEntityDef ent) - , () - ) - ) - -lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS -lookupEmbedEntity allEntities field = do - let mfieldTy = Just $ fieldType field - entName <- EntityNameHS <$> asum - [ do - FTTypeCon _ t <- mfieldTy - stripSuffix "Id" t - , do - FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy - pure entName - , do - FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- mfieldTy - stripSuffix "Id" t - ] - guard (M.member entName allEntities) -- check entity name exists in embed fmap - pure entName - -type EntityMap = M.Map EntityNameHS UnboundEntityDef - -constructEntityMap :: [UnboundEntityDef] -> EntityMap -constructEntityMap = - M.fromList . fmap (\ent -> (entityHaskell (unboundEntityDef ent), ent)) - -data FTTypeConDescr = FTKeyCon Text - deriving Show - --- | Recurses through the 'FieldType'. Returns a 'Right' with the --- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of --- a name and that name is present in the 'EmbedEntityMap' provided as --- a first argument. --- --- If the 'FieldType' represents a @Key something@, this returns a @'Left --- ('Just' 'FTKeyCon')@. --- --- If the 'FieldType' has a module qualified value, then it returns @'Left' --- 'Nothing'@. -mEmbedded - :: M.Map EntityNameHS a - -> FieldType - -> Either (Maybe FTTypeConDescr) EntityNameHS -mEmbedded _ (FTTypeCon Just{} _) = - Left Nothing -mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = - maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents -mEmbedded _ (FTTypePromoted _) = - Left Nothing -mEmbedded ents (FTList x) = - mEmbedded ents x -mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) = - Left $ Just $ FTKeyCon $ a <> "Id" -mEmbedded _ (FTApp _ _) = - Left Nothing -mEmbedded _ (FTLit _) = - Left Nothing - -setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef -setEmbedField entName allEntities field = - case fieldReference field of - NoReference -> - setFieldReference ref field - _ -> - field - where - ref = - case mEmbedded allEntities (fieldType field) of - Left _ -> fromMaybe NoReference $ do - refEntName <- lookupEmbedEntity allEntities field - pure $ ForeignRef refEntName - Right em -> - if em /= entName - then EmbedRef em - else if maybeNullable (unbindFieldDef field) - then SelfReference - else case fieldType field of - FTList _ -> SelfReference - _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe or List" - -setFieldReference :: ReferenceDef -> FieldDef -> FieldDef -setFieldReference ref field = field { fieldReference = ref } - --- | Create data types and appropriate 'PersistEntity' instances for the given --- 'UnboundEntityDef's. --- --- This function should be used if you are only defining a single block of --- Persistent models for the entire application. If you intend on defining --- multiple blocks in different fiels, see 'mkPersistWith' which allows you --- to provide existing entity definitions so foreign key references work. --- --- Example: --- --- @ --- mkPersist 'sqlSettings' ['persistLowerCase'| --- User --- name Text --- age Int --- --- Dog --- name Text --- owner UserId --- --- |] --- @ --- --- Example from a file: --- --- @ --- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels") --- @ --- --- For full information on the 'QuasiQuoter' syntax, see --- "Database.Persist.Quasi" documentation. -mkPersist - :: MkPersistSettings - -> [UnboundEntityDef] - -> Q [Dec] -mkPersist mps = mkPersistWith mps [] - --- | Like 'mkPersist', but allows you to provide a @['EntityDef']@ --- representing the predefined entities. This function will include those --- 'EntityDef' when looking for foreign key references. --- --- You should use this if you intend on defining Persistent models in --- multiple files. --- --- Suppose we define a table @Foo@ which has no dependencies. --- --- @ --- module DB.Foo where --- --- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'| --- Foo --- name Text --- |] --- @ --- --- Then, we define a table @Bar@ which depends on @Foo@: --- --- @ --- module DB.Bar where --- --- import DB.Foo --- --- 'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'| --- Bar --- fooId FooId --- |] --- @ --- --- Writing out the list of 'EntityDef' can be annoying. The --- @$('discoverEntities')@ shortcut will work to reduce this boilerplate. --- --- @ --- module DB.Quux where --- --- import DB.Foo --- import DB.Bar --- --- 'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'| --- Quux --- name Text --- fooId FooId --- barId BarId --- |] --- @ --- --- @since 2.13.0.0 -mkPersistWith - :: MkPersistSettings - -> [EntityDef] - -> [UnboundEntityDef] - -> Q [Dec] -mkPersistWith mps preexistingEntities ents' = do - let - (embedEntityMap, predefs) = - preprocessUnboundDefs preexistingEntities ents' - allEnts = - embedEntityDefs preexistingEntities - $ fmap (setDefaultIdFields mps) - $ predefs - entityMap = - constructEntityMap allEnts - preexistingSet = - Set.fromList $ map getEntityHaskellName preexistingEntities - newEnts = - filter - (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet) - allEnts - ents <- filterM shouldGenerateCode newEnts - requireExtensions - [ [TypeFamilies], [GADTs, ExistentialQuantification] - , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] - , [UndecidableInstances], [DataKinds], [FlexibleInstances] - ] - persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents - entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents - jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents - uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents - safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents - symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents - return $ mconcat - [ persistFieldDecs - , entityDecs - , jsonDecs - , uniqueKeyInstances - , symbolToFieldInstances - , safeToInsertInstances - ] - -mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] -mkSafeToInsertInstance mps ued = - case unboundPrimarySpec ued of - NaturalKey _ -> - instanceOkay - SurrogateKey uidDef -> do - let attrs = - unboundIdAttrs uidDef - isDefaultFieldAttr = \case - FieldAttrDefault _ -> - True - _ -> - False - case unboundIdType uidDef of - Nothing -> - instanceOkay - Just _ -> - case List.find isDefaultFieldAttr attrs of - Nothing -> - badInstance - Just _ -> do - instanceOkay - - DefaultKey _ -> - instanceOkay - - where - typ :: Type - typ = genericDataType mps (getUnboundEntityNameHS ued) backendT - - mkInstance merr = - InstanceD Nothing (maybe id (:) merr withPersistStoreWriteCxt) (ConT ''SafeToInsert `AppT` typ) [] - instanceOkay = - pure - [ mkInstance Nothing - ] - badInstance = do - err <- [t| TypeError (SafeToInsertErrorMessage $(pure typ)) |] - pure - [ mkInstance (Just err) - ] - - withPersistStoreWriteCxt = - if mpsGeneric mps - then - [ConT ''PersistStoreWrite `AppT` backendT] - else - [] - - --- we can't just use 'isInstance' because TH throws an error -shouldGenerateCode :: UnboundEntityDef -> Q Bool -shouldGenerateCode ed = do - mtyp <- lookupTypeName entityName - case mtyp of - Nothing -> do - pure True - Just typeName -> do - instanceExists <- isInstance ''PersistEntity [ConT typeName] - pure (not instanceExists) - where - entityName = - T.unpack . unEntityNameHS . getEntityHaskellName . unboundEntityDef $ ed - -overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef -overEntityDef f ued = ued { unboundEntityDef = f (unboundEntityDef ued) } - -setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef -setDefaultIdFields mps ued - | defaultIdType ued = - overEntityDef - (setEntityIdDef (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed))) - ued - | otherwise = - ued - where - ed = - unboundEntityDef ued - setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef - setToMpsDefault iid (EntityIdField fd) = - EntityIdField fd - { fieldType = - iidFieldType iid (getEntityHaskellName ed) - , fieldSqlType = - iidFieldSqlType iid - , fieldAttrs = - let - def = - toList (FieldAttrDefault <$> iidDefault iid) - maxlen = - toList (FieldAttrMaxlen <$> iidMaxLen iid) - in - def <> maxlen <> fieldAttrs fd - , fieldIsImplicitIdColumn = - True - } - setToMpsDefault _ x = - x - --- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. --- For example, strip out any fields marked as MigrationOnly. --- --- This should be called when performing Haskell codegen, but the 'EntityDef' --- *should* keep all of the fields present when defining 'entityDef'. This is --- necessary so that migrations know to keep these columns around, or to delete --- them, as appropriate. -fixEntityDef :: UnboundEntityDef -> UnboundEntityDef -fixEntityDef ued = - ued - { unboundEntityFields = - filter isHaskellUnboundField (unboundEntityFields ued) - } - --- | Settings to be passed to the 'mkPersist' function. -data MkPersistSettings = MkPersistSettings - { mpsBackend :: Type - -- ^ Which database backend we\'re using. This type is used for the - -- 'PersistEntityBackend' associated type in the entities that are - -- generated. - -- - -- If the 'mpsGeneric' value is set to 'True', then this type is used for - -- the non-Generic type alias. The data and type will be named: - -- - -- @ - -- data ModelGeneric backend = Model { ... } - -- @ - -- - -- And, for convenience's sake, we provide a type alias: - -- - -- @ - -- type Model = ModelGeneric $(the type you give here) - -- @ - , mpsGeneric :: Bool - -- ^ Create generic types that can be used with multiple backends. Good for - -- reusable code, but makes error messages harder to understand. Default: - -- False. - , mpsPrefixFields :: Bool - -- ^ Prefix field names with the model name. Default: True. - -- - -- Note: this field is deprecated. Use the mpsFieldLabelModifier and - -- 'mpsConstraintLabelModifier' instead. - , mpsFieldLabelModifier :: Text -> Text -> Text - -- ^ Customise the field accessors and lens names using the entity and field - -- name. Both arguments are upper cased. - -- - -- Default: appends entity and field. - -- - -- Note: this setting is ignored if mpsPrefixFields is set to False. - -- - -- @since 2.11.0.0 - , mpsAvoidHsKeyword :: Text -> Text - -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords. - -- - -- Default: suffix "_". - -- - -- @since 2.14.6.0 - , mpsConstraintLabelModifier :: Text -> Text -> Text - -- ^ Customise the Constraint names using the entity and field name. The - -- result should be a valid haskell type (start with an upper cased letter). - -- - -- Default: appends entity and field - -- - -- Note: this setting is ignored if mpsPrefixFields is set to False. - -- - -- @since 2.11.0.0 - , mpsEntityHaddocks :: Bool - -- ^ Generate Haddocks from entity documentation comments. Default: False. - -- - -- @since 2.14.6.0 - , mpsEntityJSON :: Maybe EntityJSON - -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's - -- @Nothing@, no instances will be generated. Default: - -- - -- @ - -- Just 'EntityJSON' - -- { 'entityToJSON' = 'entityIdToJSON - -- , 'entityFromJSON' = 'entityIdFromJSON - -- } - -- @ - , mpsGenerateLenses :: Bool - -- ^ Instead of generating normal field accessors, generator lens-style - -- accessors. - -- - -- Default: False - -- - -- @since 1.3.1 - , mpsDeriveInstances :: [Name] - -- ^ Automatically derive these typeclass instances for all record and key - -- types. - -- - -- Default: [] - -- - -- @since 2.8.1 - , mpsImplicitIdDef :: ImplicitIdDef - -- ^ TODO: document - -- - -- @since 2.13.0.0 - , mpsCamelCaseCompositeKeySelector :: Bool - -- ^ Should we generate composite key accessors in the correct CamelCase style. - -- - -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'False', - -- then the field part of the accessor starts with the lowercase. - -- This is a legacy style. - -- - -- @ - -- data Key CompanyUser = CompanyUserKey - -- { companyUserKeycompanyId :: CompanyId - -- , companyUserKeyuserId :: UserId - -- } - -- @ - -- - -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'True', - -- then field accessors are generated in CamelCase style. - -- - -- @ - -- data Key CompanyUser = CompanyUserKey - -- { companyUserKeyCompanyId :: CompanyId - -- , companyUserKeyUserId :: UserId - -- } - -- @ - - -- Default: False - -- - -- @since 2.14.2.0 - } - -{-# DEPRECATED mpsGeneric "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" #-} - --- | Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default --- value is 'autoIncrementingInteger'. --- --- @since 2.13.0.0 -setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings -setImplicitIdDef iid mps = - mps { mpsImplicitIdDef = iid } - -getImplicitIdType :: MkPersistSettings -> Type -getImplicitIdType = do - idDef <- mpsImplicitIdDef - isGeneric <- mpsGeneric - backendTy <- mpsBackend - pure $ iidType idDef isGeneric backendTy - -data EntityJSON = EntityJSON - { entityToJSON :: Name - -- ^ Name of the @toJSON@ implementation for @Entity a@. - , entityFromJSON :: Name - -- ^ Name of the @fromJSON@ implementation for @Entity a@. - } - --- | Create an @MkPersistSettings@ with default values. -mkPersistSettings - :: Type -- ^ Value for 'mpsBackend' - -> MkPersistSettings -mkPersistSettings backend = MkPersistSettings - { mpsBackend = backend - , mpsGeneric = False - , mpsPrefixFields = True - , mpsFieldLabelModifier = (++) - , mpsAvoidHsKeyword = (++ "_") - , mpsConstraintLabelModifier = (++) - , mpsEntityHaddocks = False - , mpsEntityJSON = Just EntityJSON - { entityToJSON = 'entityIdToJSON - , entityFromJSON = 'entityIdFromJSON - } - , mpsGenerateLenses = False - , mpsDeriveInstances = [] - , mpsImplicitIdDef = - autoIncrementingInteger - , mpsCamelCaseCompositeKeySelector = False - } - --- | Use the 'SqlPersist' backend. -sqlSettings :: MkPersistSettings -sqlSettings = mkPersistSettings $ ConT ''SqlBackend - -lowerFirst :: Text -> Text -lowerFirst t = - case uncons t of - Just (a, b) -> cons (toLower a) b - Nothing -> t - -upperFirst :: Text -> Text -upperFirst t = - case uncons t of - Just (a, b) -> cons (toUpper a) b - Nothing -> t - -dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec -dataTypeDec mps entityMap entDef = do - let - names = - mkEntityDefDeriveNames mps entDef - - let (stocks, anyclasses) = partitionEithers (fmap stratFor names) - let stockDerives = do - guard (not (null stocks)) - pure (DerivClause (Just StockStrategy) (fmap ConT stocks)) - anyclassDerives = do - guard (not (null anyclasses)) - pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses)) - unless (null anyclassDerives) $ do - requireExtensions [[DeriveAnyClass]] - let dec = DataD [] nameFinal paramsFinal - Nothing - constrs - (stockDerives <> anyclassDerives) -#if MIN_VERSION_template_haskell(2,18,0) - when (mpsEntityHaddocks mps) $ do - forM_ cols $ \((name, _, _), maybeComments) -> do - case maybeComments of - Just comment -> addModFinalizer $ - putDoc (DeclDoc name) (unpack comment) - Nothing -> pure () - case entityComments (unboundEntityDef entDef) of - Just doc -> do - addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc) - _ -> pure () -#endif - pure dec - - where - stratFor n = - if n `elem` stockClasses then - Left n - else - Right n - - stockClasses = - Set.fromList (fmap mkName - [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable" - ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable - ] - ) - - (nameFinal, paramsFinal) - | mpsGeneric mps = - ( mkEntityDefGenericName entDef - , [ mkPlainTV backendName - ] - ) - - | otherwise = - (mkEntityDefName entDef, []) - - cols :: [(VarBangType, Maybe Text)] - cols = do - fieldDef <- getUnboundFieldDefs entDef - let - recordNameE = - fieldDefToRecordName mps entDef fieldDef - strictness = - if unboundFieldStrict fieldDef - then isStrict - else notStrict - fieldIdType = - maybeIdType mps entityMap fieldDef Nothing Nothing - fieldComments = - unboundFieldComments fieldDef - pure ((recordNameE, strictness, fieldIdType), fieldComments) - - constrs - | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef - | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)] - - sumCon fieldDef = NormalC - (sumConstrName mps entDef fieldDef) - [(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)] - -uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec -uniqueTypeDec mps entityMap entDef = - DataInstD - [] -#if MIN_VERSION_template_haskell(2,15,0) - Nothing - (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT)) -#else - ''Unique - [genericDataType mps (getUnboundEntityNameHS entDef) backendT] -#endif - Nothing - (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef)) - [] - -mkUnique :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con -mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = - NormalC (mkConstraintName constr) $ toList types - where - types = - fmap (go . flip lookup3 (getUnboundFieldDefs entDef) . unFieldNameHS . fst) fields - - force = "!force" `elem` attrs - - go :: (UnboundFieldDef, IsNullable) -> (Strict, Type) - go (_, Nullable _) | not force = error nullErrMsg - go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y)) - - lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable) - lookup3 s [] = - error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr - lookup3 x (fd:rest) - | x == unFieldNameHS (unboundFieldNameHS fd) = - (fd, isUnboundFieldNullable fd) - | otherwise = - lookup3 x rest - - nullErrMsg = - mconcat [ "Error: By default Persistent disallows NULLables in an uniqueness " - , "constraint. The semantics of how NULL interacts with those constraints " - , "is non-trivial: most SQL implementations will not consider two NULL " - , "values to be equal for the purposes of an uniqueness constraint, " - , "allowing insertion of more than one row with a NULL value for the " - , "column in question. If you understand this feature of SQL and still " - , "intend to add a uniqueness constraint here, *** Use a \"!force\" " - , "attribute on the end of the line that defines your uniqueness " - , "constraint in order to disable this check. ***" ] - --- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'. --- It takes care to respect the 'mpsGeneric' setting to render an Id faithfully, --- and it also ensures that the generated Haskell type is 'Maybe' if the --- database column has that attribute. --- --- For a database schema with @'mpsGeneric' = False@, this is simple - it uses --- the @ModelNameId@ type directly. This resolves just fine. --- --- If 'mpsGeneric' is @True@, then we have to do something a bit more --- complicated. We can't refer to a @ModelNameId@ directly, because that @Id@ --- alias hides the backend type variable. Instead, we need to refer to: --- --- > Key (ModelNameGeneric backend) --- --- This means that the client code will need both the term @ModelNameId@ in --- scope, as well as the @ModelNameGeneric@ constructor, despite the fact that --- the @ModelNameId@ is the only term explicitly used (and imported). --- --- However, we're not guaranteed to have @ModelName@ in scope - we've only --- referenced @ModelNameId@ in code, and so code generation *should* work even --- without this. Consider an explicit-style import: --- --- @ --- import Model.Foo (FooId) --- --- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| --- Bar --- foo FooId --- |] --- @ --- --- This looks like it ought to work, but it would fail with @mpsGeneric@ being --- enabled. One hacky work-around is to perform a @'lookupTypeName' :: String -> --- Q (Maybe Name)@ on the @"ModelNameId"@ type string. If the @Id@ is --- a reference in the 'EntityMap' and @lookupTypeName@ returns @'Just' name@, --- then that 'Name' contains the fully qualified information needed to use the --- 'Name' without importing it at the client-site. Then we can perform a bit of --- surgery on the 'Name' to strip the @Id@ suffix, turn it into a 'Type', and --- apply the 'Key' constructor. -maybeIdType - :: MkPersistSettings - -> EntityMap - -> UnboundFieldDef - -> Maybe Name -- ^ backend - -> Maybe IsNullable - -> Type -maybeIdType mps entityMap fieldDef mbackend mnull = - maybeTyp mayNullable idType - where - mayNullable = - case mnull of - Just (Nullable ByMaybeAttr) -> - True - _ -> - maybeNullable fieldDef - idType = - fromMaybe (ftToType $ unboundFieldType fieldDef) $ do - typ <- extractForeignRef entityMap fieldDef - guard ((mpsGeneric mps)) - pure $ - ConT ''Key - `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) - - -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then - -- append Generic to the model name, probably - _removeIdFromTypeSuffix :: Name -> Type - _removeIdFromTypeSuffix oldName@(Name (OccName nm) nameFlavor) = - case stripSuffix "Id" (T.pack nm) of - Nothing -> - ConT oldName - Just name -> - ConT ''Key - `AppT` do - ConT $ Name (OccName (T.unpack name)) nameFlavor - - -- | TODO: if we keep mpsGeneric, let's incorporate this behavior here, so - -- end users don't need to import the constructor type as well as the id type - -- - -- Returns 'Nothing' if the given text does not appear to be a table reference. - -- In that case, do the usual thing for generating a type name. - -- - -- Returns a @Just typ@ if the text appears to be a model name, and if the - -- @ModelId@ type is in scope. The 'Type' is a fully qualified reference to - -- @'Key' ModelName@ such that end users won't have to import it directly. - _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type) - _lookupReferencedTable em fieldTypeText = do - let - mmodelIdString = do - fieldTypeNoId <- stripSuffix "Id" fieldTypeText - _ <- M.lookup (EntityNameHS fieldTypeNoId) em - pure (T.unpack fieldTypeText) - case mmodelIdString of - Nothing -> - pure Nothing - Just modelIdString -> do - mIdName <- lookupTypeName modelIdString - pure $ fmap _removeIdFromTypeSuffix mIdName - - _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String - _fieldNameEndsWithId ufd = go (unboundFieldType ufd) - where - go = \case - FTTypeCon mmodule name -> do - a <- stripSuffix "Id" name - pure $ - T.unpack $ mconcat - [ case mmodule of - Nothing -> - "" - Just m -> - mconcat [m, "."] - , a - , "Id" - ] - _ -> - Nothing - -backendDataType :: MkPersistSettings -> Type -backendDataType mps - | mpsGeneric mps = backendT - | otherwise = mpsBackend mps - --- | TODO: --- --- if we keep mpsGeneric --- then --- let's make this fully qualify the generic name --- else --- let's delete it -genericDataType - :: MkPersistSettings - -> EntityNameHS - -> Type -- ^ backend - -> Type -genericDataType mps name backend - | mpsGeneric mps = - ConT (mkEntityNameHSGenericName name) `AppT` backend - | otherwise = - ConT $ mkEntityNameHSName name - -degen :: [Clause] -> [Clause] -degen [] = - let err = VarE 'error `AppE` LitE (StringL - "Degenerate case, should never happen") - in [normalClause [WildP] err] -degen x = x - --- needs: --- --- * isEntitySum ed --- * field accesor --- * getEntityFields ed --- * used in goSum, or sumConstrName --- * mkEntityDefName ed --- * uses entityHaskell --- * sumConstrName ed fieldDef --- * only needs entity name and field name --- --- data MkToPersistFields = MkToPersistFields --- { isEntitySum :: Bool --- , entityHaskell :: HaskellNameHS --- , entityFieldNames :: [FieldNameHS] --- } -mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec -mkToPersistFields mps ed = do - let isSum = unboundEntitySum ed - fields = getUnboundFieldDefs ed - clauses <- - if isSum - then sequence $ zipWith goSum fields [1..] - else fmap return go - return $ FunD 'toPersistFields clauses - where - go :: Q Clause - go = do - xs <- sequence $ replicate fieldCount $ newName "x" - let name = mkEntityDefName ed - pat = conp name $ fmap VarP xs - sp <- [|toPersistValue|] - let bod = ListE $ fmap (AppE sp . VarE) xs - return $ normalClause [pat] bod - - fieldCount = length (getUnboundFieldDefs ed) - - goSum :: UnboundFieldDef -> Int -> Q Clause - goSum fieldDef idx = do - let name = sumConstrName mps ed fieldDef - enull <- [|PersistNull|] - let beforeCount = idx - 1 - afterCount = fieldCount - idx - before = replicate beforeCount enull - after = replicate afterCount enull - x <- newName "x" - sp <- [|toPersistValue|] - let body = ListE $ mconcat - [ before - , [sp `AppE` VarE x] - , after - ] - return $ normalClause [conp name [VarP x]] body - -mkToFieldNames :: [UniqueDef] -> Q Dec -mkToFieldNames pairs = do - pairs' <- mapM go pairs - return $ FunD 'persistUniqueToFieldNames $ degen pairs' - where - go (UniqueDef constr _ names _) = do - names' <- lift names - return $ - normalClause - [RecP (mkConstraintName constr) []] - names' - -mkUniqueToValues :: [UniqueDef] -> Q Dec -mkUniqueToValues pairs = do - pairs' <- mapM go pairs - return $ FunD 'persistUniqueToValues $ degen pairs' - where - go :: UniqueDef -> Q Clause - go (UniqueDef constr _ names _) = do - xs <- mapM (const $ newName "x") names - let pat = conp (mkConstraintName constr) $ fmap VarP $ toList xs - tpv <- [|toPersistValue|] - let bod = ListE $ fmap (AppE tpv . VarE) $ toList xs - return $ normalClause [pat] bod - -isNotNull :: PersistValue -> Bool -isNotNull PersistNull = False -isNotNull _ = True - -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft _ (Right r) = Right r -mapLeft f (Left l) = Left (f l) - --- needs: --- --- * getEntityFields --- * sumConstrName on field --- * fromValues --- * entityHaskell --- * sumConstrName --- * entityDefConE --- --- -mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause] -mkFromPersistValues mps entDef - | unboundEntitySum entDef = do - nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] - clauses <- mkClauses [] $ getUnboundFieldDefs entDef - return $ clauses `mappend` [normalClause [WildP] nothing] - | otherwise = - fromValues entDef "fromPersistValues" entE - $ fmap unboundFieldNameHS - $ filter isHaskellUnboundField - $ getUnboundFieldDefs entDef - where - entName = unEntityNameHS $ getUnboundEntityNameHS entDef - mkClauses _ [] = return [] - mkClauses before (field:after) = do - x <- newName "x" - let null' = conp 'PersistNull [] - pat = ListP $ mconcat - [ fmap (const null') before - , [VarP x] - , fmap (const null') after - ] - constr = ConE $ sumConstrName mps entDef field - fs <- [|fromPersistValue $(return $ VarE x)|] - let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x - let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] - clauses <- mkClauses (field : before) after - return $ clause : clauses - entE = entityDefConE entDef - - -type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t - -lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b -lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) - -fmapE :: Exp -fmapE = VarE 'fmap - -unboundEntitySum :: UnboundEntityDef -> Bool -unboundEntitySum = entitySum . unboundEntityDef - -fieldSel :: Name -> Name -> Exp -fieldSel conName fieldName - = LamE [RecP conName [(fieldName, VarP xName)]] (VarE xName) - where - xName = mkName "x" - -fieldUpd :: Name -- ^ constructor name - -> [Name] -- ^ list of field names - -> Exp -- ^ record value - -> Name -- ^ field name to update - -> Exp -- ^ new value - -> Q Exp -fieldUpd con names record name new = do - pats <- - fmap mconcat $ forM names $ \k -> do - varName <- VarP <$> newName (nameBase k) - pure [(k, varName) | k /= name] - - pure $ CaseE record - [ Match (RecP con pats) (NormalB body) []] - where - body = RecConE con - [ if k == name then (name, new) else (k, VarE k) - | k <- names - ] - -mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause] -mkLensClauses mps entDef _genDataType = do - lens' <- [|lensPTH|] - getId <- [|entityKey|] - setId <- [|\(Entity _ value) key -> Entity key value|] - getVal <- [|entityVal|] - dot <- [|(.)|] - keyVar <- newName "key" - valName <- newName "value" - xName <- newName "x" - let idClause = normalClause - [conp (keyIdName entDef) []] - (lens' `AppE` getId `AppE` setId) - (idClause :) <$> if unboundEntitySum entDef - then pure $ fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef) - else zipWithM (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames - where - fieldNames = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef - toClause lens' getVal dot keyVar valName xName fieldDef fieldName = do - setter <- mkSetter - pure $ normalClause - [conp (filterConName mps entDef fieldDef) []] - (lens' `AppE` getter `AppE` setter) - where - defName = mkEntityDefName entDef - getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal) - mkSetter = do - updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName) - pure $ LamE - [ conp 'Entity [VarP keyVar, VarP valName] - , VarP xName - ] - $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr - - toSumClause lens' keyVar valName xName fieldDef = normalClause - [conp (filterConName mps entDef fieldDef) []] - (lens' `AppE` getter `AppE` setter) - where - emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) [] - getter = LamE - [ conp 'Entity [WildP, VarP valName] - ] $ CaseE (VarE valName) - $ Match (conp (sumConstrName mps entDef fieldDef) [VarP xName]) (NormalB $ VarE xName) [] - - -- FIXME It would be nice if the types expressed that the Field is - -- a sum type and therefore could result in Maybe. - : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else [] - setter = LamE - [ conp 'Entity [VarP keyVar, WildP] - , VarP xName - ] - $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps entDef fieldDef) `AppE` VarE xName) - --- | declare the key type and associated instances --- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field -mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec]) -mkKeyTypeDec mps entDef = do - (instDecs, i) <- - if mpsGeneric mps - then if not useNewtype - then do pfDec <- pfInstD - return (pfDec, supplement [''Generic]) - else do gi <- genericNewtypeInstances - return (gi, supplement []) - else if not useNewtype - then do pfDec <- pfInstD - return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic]) - else do - let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON] - if customKeyType - then return ([], allInstances) - else do - bi <- backendKeyI - return (bi, allInstances) - - requirePersistentExtensions - - -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1" - -- This is much better for debugging/logging purposes - -- cf. https://github.com/yesodweb/persistent/issues/1104 - let alwaysStockStrategyTypeclasses = [''Show, ''Read] - deriveClauses = fmap (\typeclass -> - if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses) - then DerivClause (Just StockStrategy) [(ConT typeclass)] - else DerivClause (Just NewtypeStrategy) [(ConT typeclass)] - ) i - -#if MIN_VERSION_template_haskell(2,15,0) - let kd = if useNewtype - then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses - else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses -#else - let kd = if useNewtype - then NewtypeInstD [] k [recordType] Nothing dec deriveClauses - else DataInstD [] k [recordType] Nothing [dec] deriveClauses -#endif - return (kd, instDecs) - where - keyConE = keyConExp entDef - unKeyE = unKeyExp entDef - dec = RecC (keyConName entDef) (toList $ keyFields mps entDef) - k = ''Key - recordType = - genericDataType mps (getUnboundEntityNameHS entDef) backendT - pfInstD = -- FIXME: generate a PersistMap instead of PersistList - [d|instance PersistField (Key $(pure recordType)) where - toPersistValue = PersistList . keyToValues - fromPersistValue (PersistList l) = keyFromValues l - fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got - instance PersistFieldSql (Key $(pure recordType)) where - sqlType _ = SqlString - instance ToJSON (Key $(pure recordType)) - instance FromJSON (Key $(pure recordType)) - |] - - backendKeyGenericI = - [d| instance PersistStore $(pure backendT) => - ToBackendKey $(pure backendT) $(pure recordType) where - toBackendKey = $(return unKeyE) - fromBackendKey = $(return keyConE) - |] - backendKeyI = let bdt = backendDataType mps in - [d| instance ToBackendKey $(pure bdt) $(pure recordType) where - toBackendKey = $(return unKeyE) - fromBackendKey = $(return keyConE) - |] - - genericNewtypeInstances = do - requirePersistentExtensions - - alwaysInstances <- - -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here - [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) - deriving stock instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) - deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) - deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) - deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType)) - deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType)) - deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) - deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) - deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) - deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) - deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) - |] - - mappend alwaysInstances <$> - if customKeyType - then pure [] - else backendKeyGenericI - - useNewtype = pkNewtype mps entDef - customKeyType = - or - [ not (defaultIdType entDef) - , not useNewtype - , isJust (entityPrimary (unboundEntityDef entDef)) - , not isBackendKey - ] - - isBackendKey = - case getImplicitIdType mps of - ConT bk `AppT` _ - | bk == ''BackendKey -> - True - _ -> - False - - supplement :: [Name] -> [Name] - supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) - --- | Returns 'True' if the key definition has less than 2 fields. --- --- @since 2.11.0.0 -pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool -pkNewtype mps entDef = length (keyFields mps entDef) < 2 - --- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the --- QuasiQuoter produces for an implicit ID and -defaultIdType :: UnboundEntityDef -> Bool -defaultIdType entDef = - case unboundPrimarySpec entDef of - DefaultKey _ -> - True - _ -> - False - -keyFields :: MkPersistSettings -> UnboundEntityDef -> NonEmpty (Name, Strict, Type) -keyFields mps entDef = - case unboundPrimarySpec entDef of - NaturalKey ucd -> - fmap naturalKeyVar (unboundCompositeCols ucd) - DefaultKey _ -> - pure . idKeyVar $ getImplicitIdType mps - SurrogateKey k -> - pure . idKeyVar $ case unboundIdType k of - Nothing -> - getImplicitIdType mps - Just ty -> - ftToType ty - where - unboundFieldDefs = - getUnboundFieldDefs entDef - naturalKeyVar fieldName = - case findField fieldName unboundFieldDefs of - Nothing -> - error "column not defined on entity" - Just unboundFieldDef -> - ( keyFieldName mps entDef (unboundFieldNameHS unboundFieldDef) - , notStrict - , ftToType $ unboundFieldType unboundFieldDef - ) - - idKeyVar ft = - ( unKeyName entDef - , notStrict - , ft - ) - -findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef -findField fieldName = - List.find ((fieldName ==) . unboundFieldNameHS) - -mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec -mkKeyToValues mps entDef = do - recordN <- newName "record" - FunD 'keyToValues . pure <$> - case unboundPrimarySpec entDef of - NaturalKey ucd -> do - normalClause [VarP recordN] <$> - toValuesPrimary recordN ucd - _ -> do - normalClause [] <$> - [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|] - where - toValuesPrimary recName ucd = - ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd) - f recName fieldNameHS = - [| - toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName)) - |] - keyFieldSel name - = fieldSel (keyConName entDef) (keyFieldName mps entDef name) - -normalClause :: [Pat] -> Exp -> Clause -normalClause p e = Clause p (NormalB e) [] - --- needs: --- --- * entityPrimary --- * keyConExp entDef -mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec -mkKeyFromValues _mps entDef = - FunD 'keyFromValues <$> - case unboundPrimarySpec entDef of - NaturalKey ucd -> - fromValues entDef "keyFromValues" keyConE (toList $ unboundCompositeCols ucd) - _ -> do - e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] - return [normalClause [] e] - where - keyConE = keyConExp entDef - -headNote :: [PersistValue] -> PersistValue -headNote = \case - [x] -> x - xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs - --- needs from entity: --- --- * entityText entDef --- * entityHaskell --- * entityDB entDef --- --- needs from fields: --- --- * mkPersistValue --- * fieldHaskell --- --- data MkFromValues = MkFromValues --- { entityHaskell :: EntityNameHS --- , entityDB :: EntitynameDB --- , entityFieldNames :: [FieldNameHS] --- } -fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause] -fromValues entDef funName constructExpr fields = do - x <- newName "x" - let - funMsg = - mconcat - [ entityText entDef - , ": " - , funName - , " failed on: " - ] - patternMatchFailure <- - [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] - suc <- patternSuccess - return [ suc, normalClause [VarP x] patternMatchFailure ] - where - tableName = - unEntityNameDB (entityDB (unboundEntityDef entDef)) - patternSuccess = - case fields of - [] -> do - rightE <- [|Right|] - return $ normalClause [ListP []] (rightE `AppE` constructExpr) - _ -> do - x1 <- newName "x1" - restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields] - (fpv1:mkPersistValues) <- mapM mkPersistValue fields - app1E <- [|(<$>)|] - let conApp = infixFromPersistValue app1E fpv1 constructExpr x1 - applyE <- [|(<*>)|] - let applyFromPersistValue = infixFromPersistValue applyE - - return $ normalClause - [ListP $ fmap VarP (x1:restNames)] - (List.foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues)) - - infixFromPersistValue applyE fpv exp name = - UInfixE exp applyE (fpv `AppE` VarE name) - - mkPersistValue field = - let fieldName = unFieldNameHS field - in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|] - --- | Render an error message based on the @tableName@ and @fieldName@ with --- the provided message. --- --- @since 2.8.2 -fieldError :: Text -> Text -> Text -> Text -fieldError tableName fieldName err = mconcat - [ "Couldn't parse field `" - , fieldName - , "` from table `" - , tableName - , "`. " - , err - ] - -mkEntity :: M.Map EntityNameHS a -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec] -mkEntity embedEntityMap entityMap mps preDef = do - when (isEntitySum (unboundEntityDef preDef)) $ do - reportWarning $ unlines - [ "persistent has deprecated sum type entities as of 2.14.0.0." - , "We will delete support for these entities in 2.15.0.0." - , "If you need these, please add a comment on this GitHub issue:" - , "" - , " https://github.com/yesodweb/persistent/issues/987" - ] - - entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef - let - entDef = - fixEntityDef preDef - fields <- mkFields mps entityMap entDef - let name = mkEntityDefName entDef - let clazz = ConT ''PersistEntity `AppT` genDataType - tpf <- mkToPersistFields mps entDef - fpv <- mkFromPersistValues mps entDef - utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef - puk <- mkUniqueKeys entDef - fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef - - toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef - - (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef - keyToValues' <- mkKeyToValues mps entDef - keyFromValues' <- mkKeyFromValues mps entDef - - let addSyn -- FIXME maybe remove this - | mpsGeneric mps = (:) $ - TySynD name [] $ - genericDataType mps entName $ mpsBackend mps - | otherwise = id - - lensClauses <- mkLensClauses mps entDef genDataType - - lenses <- mkLenses mps entityMap entDef - let instanceConstraint = if not (mpsGeneric mps) then [] else - [mkClassP ''PersistStore [backendT]] - - [keyFromRecordM'] <- - case unboundPrimarySpec entDef of - NaturalKey ucd -> do - let keyFields' = fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd - keyFieldNames' <- forM keyFields' $ \fieldName -> do - fieldVarName <- newName (nameBase fieldName) - return (fieldName, fieldVarName) - - let keyCon = keyConName entDef - constr = - List.foldl' - AppE - (ConE keyCon) - (VarE . snd <$> keyFieldNames') - keyFromRec = varP 'keyFromRecordM - fieldPat = [(fieldName, VarP fieldVarName) | (fieldName, fieldVarName) <- toList keyFieldNames'] - lam = LamE [RecP name fieldPat ] constr - [d| - $(keyFromRec) = Just $(pure lam) - |] - - _ -> - [d|$(varP 'keyFromRecordM) = Nothing|] - - dtd <- dataTypeDec mps entityMap entDef - let - allEntDefs = - entityFieldTHCon <$> efthAllFields fields - allEntDefClauses = - entityFieldTHClause <$> efthAllFields fields - - mkTabulateA <- do - fromFieldName <- newName "fromField" - let names'types = - filter (\(n, _) -> n /= mkName "Id") $ map (getConNameAndType . entityFieldTHCon) $ entityFieldsTHFields fields - getConNameAndType = \case - ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC conName []) -> - (conName, fieldTy) - other -> - error $ mconcat - [ "persistent internal error: field constructor did not have xpected shape. \n" - , "Expected: \n" - , " ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n" - , "Got: \n" - , " " <> show other - ] - mkEntityVal = - List.foldl' - (\acc (n, _) -> - InfixE - (Just acc) - (VarE '(<*>)) - (Just (VarE fromFieldName `AppE` ConE n)) - ) - (VarE 'pure `AppE` ConE (mkEntityNameHSName entName)) - names'types - primaryKeyField = - fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields - body <- - if isEntitySum $ unboundEntityDef entDef - then [| error "tabulateEntityA does not make sense for sum type" |] - else - [| - Entity - <$> $(varE fromFieldName) $(conE primaryKeyField) - <*> $(pure mkEntityVal) - |] - - - pure $ - FunD 'tabulateEntityA - [ Clause [VarP fromFieldName] (NormalB body) [] - ] - - return $ addSyn $ - dtd : mconcat fkc `mappend` - ( [ TySynD (keyIdName entDef) [] $ - ConT ''Key `AppT` ConT name - , instanceD instanceConstraint clazz - [ uniqueTypeDec mps entityMap entDef - , keyTypeDec - , keyToValues' - , keyFromValues' - , keyFromRecordM' - , mkTabulateA - , FunD 'entityDef [normalClause [WildP] entityDefExp] - , tpf - , FunD 'fromPersistValues fpv - , toFieldNames - , utv - , puk -#if MIN_VERSION_template_haskell(2,15,0) - , DataInstD - [] - Nothing - (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) - Nothing - allEntDefs - [] -#else - , DataInstD - [] - ''EntityField - [ genDataType - , VarT $ mkName "typ" - ] - Nothing - allEntDefs - [] -#endif - , FunD 'persistFieldDef allEntDefClauses -#if MIN_VERSION_template_haskell(2,15,0) - , TySynInstD - (TySynEqn - Nothing - (AppT (ConT ''PersistEntityBackend) genDataType) - (backendDataType mps)) -#else - , TySynInstD - ''PersistEntityBackend - (TySynEqn - [genDataType] - (backendDataType mps)) -#endif - , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)] - , FunD 'fieldLens lensClauses - ] - ] `mappend` lenses) `mappend` keyInstanceDecs - where - genDataType = - genericDataType mps entName backendT - entName = - getUnboundEntityNameHS preDef - -data EntityFieldsTH = EntityFieldsTH - { entityFieldsTHPrimary :: EntityFieldTH - , entityFieldsTHFields :: [EntityFieldTH] - } - -efthAllFields :: EntityFieldsTH -> [EntityFieldTH] -efthAllFields EntityFieldsTH{..} = - stripIdFieldDef entityFieldsTHPrimary : entityFieldsTHFields - -stripIdFieldDef :: EntityFieldTH -> EntityFieldTH -stripIdFieldDef efth = efth - { entityFieldTHClause = - go (entityFieldTHClause efth) - } - where - go (Clause ps bdy ds) = - Clause ps bdy' ds - where - bdy' = - case bdy of - NormalB e -> - NormalB $ AppE (VarE 'stripIdFieldImpl) e - _ -> - bdy - --- | @persistent@ used to assume that an Id was always a single field. --- --- This method preserves as much backwards compatibility as possible. -stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef -stripIdFieldImpl eid = - case eid of - EntityIdField fd -> fd - EntityIdNaturalKey cd -> - case compositeFields cd of - (x :| xs) -> - case xs of - [] -> - x - _ -> - dummyFieldDef - where - dummyFieldDef = - FieldDef - { fieldHaskell = - FieldNameHS "Id" - , fieldDB = - FieldNameDB "__composite_key_no_id__" - , fieldType = - FTTypeCon Nothing "__Composite_Key__" - , fieldSqlType = - SqlOther "Composite Key" - , fieldAttrs = - [] - , fieldStrict = - False - , fieldReference = - NoReference - , fieldCascade = - noCascade - , fieldComments = - Nothing - , fieldGenerated = - Nothing - , fieldIsImplicitIdColumn = - False - } - -mkFields :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH -mkFields mps entityMap entDef = - EntityFieldsTH - <$> mkIdField mps entDef - <*> mapM (mkField mps entityMap entDef) (getUnboundFieldDefs entDef) - -mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] -mkUniqueKeyInstances mps entDef = do - requirePersistentExtensions - case entityUniques (unboundEntityDef entDef) of - [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne - [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey - (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey - where - requireUniquesPName = 'requireUniquesP - onlyUniquePName = 'onlyUniqueP - typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx - typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx - - withPersistStoreWriteCxt = - if mpsGeneric mps - then do - write <- [t|PersistStoreWrite $(pure backendT) |] - pure [write] - else do - pure [] - - typeErrorNoneCtx = do - tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|] - (tyErr :) <$> withPersistStoreWriteCxt - - typeErrorMultipleCtx = do - tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|] - (tyErr :) <$> withPersistStoreWriteCxt - - mkOnlyUniqueError :: Q Cxt -> Q [Dec] - mkOnlyUniqueError mkCtx = do - ctx <- mkCtx - let impl = mkImpossible onlyUniquePName - pure [instanceD ctx onlyOneUniqueKeyClass impl] - - mkImpossible name = - [ FunD name - [ Clause - [ WildP ] - (NormalB - (VarE 'error `AppE` LitE (StringL "impossible")) - ) - [] - ] - ] - - typeErrorAtLeastOne :: Q [Dec] - typeErrorAtLeastOne = do - let impl = mkImpossible requireUniquesPName - cxt <- typeErrorNoneCtx - pure [instanceD cxt atLeastOneUniqueKeyClass impl] - - singleUniqueKey :: Q [Dec] - singleUniqueKey = do - expr <- [e| head . persistUniqueKeys|] - let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] - cxt <- withPersistStoreWriteCxt - pure [instanceD cxt onlyOneUniqueKeyClass impl] - - atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType - onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType - - atLeastOneKey :: Q [Dec] - atLeastOneKey = do - expr <- [e| NEL.fromList . persistUniqueKeys|] - let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] - cxt <- withPersistStoreWriteCxt - pure [instanceD cxt atLeastOneUniqueKeyClass impl] - - genDataType = - genericDataType mps (getUnboundEntityNameHS entDef) backendT - -entityText :: UnboundEntityDef -> Text -entityText = unEntityNameHS . getUnboundEntityNameHS - -mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] -mkLenses mps _ _ | not (mpsGenerateLenses mps) = return [] -mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return [] -mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` fieldNames) $ \(field, fieldName) -> do - let lensName = mkEntityLensName mps ent field - needleN <- newName "needle" - setterN <- newName "setter" - fN <- newName "f" - aN <- newName "a" - yN <- newName "y" - let needle = VarE needleN - setter = VarE setterN - f = VarE fN - a = VarE aN - y = VarE yN - fT = mkName "f" - -- FIXME if we want to get really fancy, then: if this field is the - -- *only* Id field present, then set backend1 and backend2 to different - -- values - backend1 = backendName - backend2 = backendName - aT = - maybeIdType mps entityMap field (Just backend1) Nothing - bT = - maybeIdType mps entityMap field (Just backend2) Nothing - mkST backend = - genericDataType mps (getUnboundEntityNameHS ent) (VarT backend) - sT = mkST backend1 - tT = mkST backend2 - t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 - vars = mkForallTV fT - : (if mpsGeneric mps then [mkForallTV backend1{-, PlainTV backend2-}] else []) - fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y - return - [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $ - (aT `arrow` (VarT fT `AppT` bT)) `arrow` - (sT `arrow` (VarT fT `AppT` tT)) - , FunD lensName $ return $ Clause - [VarP fN, VarP aN] - (NormalB $ fmapE - `AppE` setter - `AppE` (f `AppE` needle)) - [ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)] - , FunD setterN $ return $ normalClause - [VarP yN] - fieldUpdClause - ] - ] - where - fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent - -#if MIN_VERSION_template_haskell(2,21,0) -mkPlainTV - :: Name - -> TyVarBndr BndrVis -mkPlainTV n = PlainTV n defaultBndrFlag - -mkForallTV :: Name -> TyVarBndr Specificity -mkForallTV n = PlainTV n SpecifiedSpec -#elif MIN_VERSION_template_haskell(2,17,0) -mkPlainTV - :: Name - -> TyVarBndr () -mkPlainTV n = PlainTV n () - -mkForallTV :: Name -> TyVarBndr Specificity -mkForallTV n = PlainTV n SpecifiedSpec -#else - -mkPlainTV - :: Name - -> TyVarBndr -mkPlainTV = PlainTV - -mkForallTV - :: Name - -> TyVarBndr -mkForallTV = mkPlainTV -#endif - -mkForeignKeysComposite - :: MkPersistSettings - -> UnboundEntityDef - -> UnboundForeignDef - -> Q [Dec] -mkForeignKeysComposite mps entDef foreignDef - | foreignToPrimary (unboundForeignDef foreignDef) = do - let - fieldName = - fieldNameToRecordName mps entDef - fname = - fieldName $ constraintToField $ foreignConstraintNameHaskell $ unboundForeignDef foreignDef - reftableString = - unpack $ unEntityNameHS $ foreignRefTableHaskell $ unboundForeignDef foreignDef - reftableKeyName = - mkName $ reftableString `mappend` "Key" - tablename = - mkEntityDefName entDef - fieldStore = - mkFieldStore entDef - - recordVarName <- newName "record_mkForeignKeysComposite" - - let - mkFldE foreignName = - -- using coerce here to convince SqlBackendKey to go away - VarE 'coerce `AppE` - (VarE (fieldName foreignName) `AppE` VarE recordVarName) - mkFldR ffr = - let - e = - mkFldE (ffrSourceField ffr) - in - case ffrTargetField ffr of - FieldNameHS "Id" -> - VarE 'toBackendKey `AppE` - e - _ -> - e - foreignFieldNames foreignFieldList = - case foreignFieldList of - FieldListImpliedId names -> - names - FieldListHasReferences refs -> - fmap ffrSourceField refs - - fldsE = - getForeignNames $ (unboundForeignFields foreignDef) - getForeignNames = \case - FieldListImpliedId xs -> - fmap mkFldE xs - FieldListHasReferences xs -> - fmap mkFldR xs - - nullErr n = - error $ "Could not find field definition for: " <> show n - fNullable = - setNull - $ fmap (\n -> fromMaybe (nullErr n) $ getFieldDef n fieldStore) - $ foreignFieldNames - $ unboundForeignFields foreignDef - mkKeyE = - List.foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE - fn = - FunD fname [normalClause [VarP recordVarName] mkKeyE] - - keyTargetTable = - maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString) - - sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |] - pure - [ SigD fname sigTy - , fn - ] - - | otherwise = - pure [] - where - constraintToField = FieldNameHS . unConstraintNameHS - - -maybeExp :: Bool -> Exp -> Exp -maybeExp may exp | may = fmapE `AppE` exp - | otherwise = exp - -maybeTyp :: Bool -> Type -> Type -maybeTyp may typ | may = ConT ''Maybe `AppT` typ - | otherwise = typ - -entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue -entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues - where - columnNames = fmap (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity))) - fieldsAsPersistValues = fmap toPersistValue $ toPersistFields entity - -entityFromPersistValueHelper - :: (PersistEntity record) - => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code - -> PersistValue - -> Either Text record -entityFromPersistValueHelper columnNames pv = do - (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv - - let columnMap = HM.fromList persistMap - lookupPersistValueByColumnName :: String -> PersistValue - lookupPersistValueByColumnName columnName = - fromMaybe PersistNull (HM.lookup (pack columnName) columnMap) - - fromPersistValues $ fmap lookupPersistValueByColumnName columnNames - --- | Produce code similar to the following: --- --- @ --- instance PersistEntity e => PersistField e where --- toPersistValue = entityToPersistValueHelper --- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] --- sqlType _ = SqlString --- @ -persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] -persistFieldFromEntity mps entDef = do - sqlStringConstructor' <- [|SqlString|] - toPersistValueImplementation <- [|entityToPersistValueHelper|] - fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|] - - return - [ persistFieldInstanceD (mpsGeneric mps) typ - [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ] - , FunD 'fromPersistValue - [ normalClause [] fromPersistValueImplementation ] - ] - , persistFieldSqlInstanceD (mpsGeneric mps) typ - [ sqlTypeFunD sqlStringConstructor' - ] - ] - where - typ = - genericDataType mps (entityHaskell (unboundEntityDef entDef)) backendT - entFields = - filter isHaskellUnboundField $ getUnboundFieldDefs entDef - columnNames = - fmap (unpack . unFieldNameHS . unboundFieldNameHS) entFields - --- | Apply the given list of functions to the same @EntityDef@s. --- --- This function is useful for cases such as: --- --- @ --- share ['mkEntityDefList' "myDefs", 'mkPersist' sqlSettings] ['persistLowerCase'| --- -- ... --- |] --- @ --- --- If you only have a single function, though, you don't need this. The --- following is redundant: --- --- @ --- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'| --- -- ... --- |] --- @ --- --- Most functions require a full @['EntityDef']@, which can be provided --- using @$('discoverEntities')@ for all entites in scope, or defining --- 'mkEntityDefList' to define a list of entities from the given block. -share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] -share fs x = mconcat <$> mapM ($ x) fs - --- | Creates a declaration for the @['EntityDef']@ from the @persistent@ --- schema. This is necessary because the Persistent QuasiQuoter is unable --- to know the correct type of ID fields, and assumes that they are all --- Int64. --- --- Provide this in the list you give to 'share', much like @'mkMigrate'@. --- --- @ --- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...] --- @ --- --- @since 2.7.1 -mkEntityDefList - :: String - -- ^ The name that will be given to the 'EntityDef' list. - -> [UnboundEntityDef] - -> Q [Dec] -mkEntityDefList entityList entityDefs = do - let entityListName = mkName entityList - edefs <- fmap ListE - . forM entityDefs - $ \entDef -> - let entityType = entityDefConT entDef - in [|entityDef (Proxy :: Proxy $(entityType))|] - typ <- [t|[EntityDef]|] - pure - [ SigD entityListName typ - , ValD (VarP entityListName) (NormalB edefs) [] - ] - -mkUniqueKeys :: UnboundEntityDef -> Q Dec -mkUniqueKeys def | entitySum (unboundEntityDef def) = - return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] -mkUniqueKeys def = do - c <- clause - return $ FunD 'persistUniqueKeys [c] - where - clause = do - xs <- forM (getUnboundFieldDefs def) $ \fieldDef -> do - let x = unboundFieldNameHS fieldDef - x' <- newName $ '_' : unpack (unFieldNameHS x) - return (x, x') - let pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def - let pat = conp - (mkEntityDefName def) - (fmap (VarP . snd) xs) - return $ normalClause [pat] (ListE pcs) - - go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp - go xs (UniqueDef name _ cols _) = - List.foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols) - - go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp - go' xs front col = - let col' = - fromMaybe (error $ "failed in go' while looking up col=" <> show col) (lookup col xs) - in front `AppE` VarE col' - -sqlTypeFunD :: Exp -> Dec -sqlTypeFunD st = FunD 'sqlType - [ normalClause [WildP] st ] - -typeInstanceD - :: Name - -> Bool -- ^ include PersistStore backend constraint - -> Type - -> [Dec] - -> Dec -typeInstanceD clazz hasBackend typ = - instanceD ctx (ConT clazz `AppT` typ) - where - ctx - | hasBackend = [mkClassP ''PersistStore [backendT]] - | otherwise = [] - -persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint - -> Type -> [Dec] -> Dec -persistFieldInstanceD = typeInstanceD ''PersistField - -persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint - -> Type -> [Dec] -> Dec -persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql - --- | Automatically creates a valid 'PersistField' instance for any datatype --- that has valid 'Show' and 'Read' instances. Can be very convenient for --- 'Enum' types. -derivePersistField :: String -> Q [Dec] -derivePersistField s = do - ss <- [|SqlString|] - tpv <- [|PersistText . pack . show|] - fpv <- [|\dt v -> - case fromPersistValue v of - Left e -> Left e - Right s' -> - case reads $ unpack s' of - (x, _):_ -> Right x - [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|] - return - [ persistFieldInstanceD False (ConT $ mkName s) - [ FunD 'toPersistValue - [ normalClause [] tpv - ] - , FunD 'fromPersistValue - [ normalClause [] (fpv `AppE` LitE (StringL s)) - ] - ] - , persistFieldSqlInstanceD False (ConT $ mkName s) - [ sqlTypeFunD ss - ] - ] - --- | Automatically creates a valid 'PersistField' instance for any datatype --- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it --- generates instances similar to these: --- --- @ --- instance PersistField T where --- toPersistValue = PersistByteString . L.toStrict . encode --- fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue --- instance PersistFieldSql T where --- sqlType _ = SqlString --- @ -derivePersistFieldJSON :: String -> Q [Dec] -derivePersistFieldJSON s = do - ss <- [|SqlString|] - tpv <- [|PersistText . toJsonText|] - fpv <- [|\dt v -> do - text <- fromPersistValue v - let bs' = TE.encodeUtf8 text - case eitherDecodeStrict' bs' of - Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs' - Right x -> Right x|] - return - [ persistFieldInstanceD False (ConT $ mkName s) - [ FunD 'toPersistValue - [ normalClause [] tpv - ] - , FunD 'fromPersistValue - [ normalClause [] (fpv `AppE` LitE (StringL s)) - ] - ] - , persistFieldSqlInstanceD False (ConT $ mkName s) - [ sqlTypeFunD ss - ] - ] - --- | The basic function for migrating models, no Template Haskell required. --- --- It's probably best to use this in concert with 'mkEntityDefList', and then --- call 'migrateModels' with the result from that function. --- --- @ --- share [mkPersist sqlSettings, mkEntityDefList "entities"] [persistLowerCase| ... |] --- --- migrateAll = 'migrateModels' entities --- @ --- --- The function 'mkMigrate' currently implements exactly this behavior now. If --- you're splitting up the entity definitions into separate files, then it is --- better to use the entity definition list and the concatenate all the models --- together into a big list to call with 'migrateModels'. --- --- @ --- module Foo where --- --- share [mkPersist s, mkEntityDefList "fooModels"] ... --- --- --- module Bar where --- --- share [mkPersist s, mkEntityDefList "barModels"] ... --- --- module Migration where --- --- import Foo --- import Bar --- --- migrateAll = migrateModels (fooModels <> barModels) --- @ --- --- @since 2.13.0.0 -migrateModels :: [EntityDef] -> Migration -migrateModels defs= - forM_ (filter isMigrated defs) $ \def -> - migrate defs def - where - isMigrated def = pack "no-migrate" `notElem` entityAttrs def - --- | Creates a single function to perform all migrations for the entities --- defined here. One thing to be aware of is dependencies: if you have entities --- with foreign references, make sure to place those definitions after the --- entities they reference. --- --- In @persistent-2.13.0.0@, this was changed to *ignore* the input entity def --- list, and instead defer to 'mkEntityDefList' to get the correct entities. --- This avoids problems where the QuasiQuoter is unable to know what the right --- reference types are. This sets 'mkPersist' to be the "single source of truth" --- for entity definitions. -mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec] -mkMigrate fun eds = do - let entityDefListName = ("entityDefListFor" <> fun) - body <- [| migrateModels $(varE (mkName entityDefListName)) |] - edList <- mkEntityDefList entityDefListName eds - pure $ edList <> - [ SigD (mkName fun) (ConT ''Migration) - , FunD (mkName fun) [normalClause [] body] - ] - -data EntityFieldTH = EntityFieldTH - { entityFieldTHCon :: Con - , entityFieldTHClause :: Clause - } - --- Ent --- fieldName FieldType --- --- forall . typ ~ FieldType => EntFieldName --- --- EntFieldName = FieldDef .... --- --- Field Def Accessors Required: -mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH -mkField mps entityMap et fieldDef = do - let - con = - ForallC - [] - [mkEqualP (VarT $ mkName "typ") fieldT] - $ NormalC name [] - fieldT = - maybeIdType mps entityMap fieldDef Nothing Nothing - bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef) - let cla = normalClause - [conp name []] - bod - return $ EntityFieldTH con cla - where - name = filterConName mps et fieldDef - -mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH -mkIdField mps ued = do - let - entityName = - getUnboundEntityNameHS ued - entityIdType - | mpsGeneric mps = - ConT ''Key `AppT` ( - ConT (mkEntityNameHSGenericName entityName) - `AppT` backendT - ) - | otherwise = - ConT $ mkName $ (T.unpack $ unEntityNameHS entityName) ++ "Id" - name = - filterConName' mps entityName (FieldNameHS "Id") - clause <- - fixPrimarySpec mps ued - pure EntityFieldTH - { entityFieldTHCon = - ForallC - [] - [mkEqualP (VarT $ mkName "typ") entityIdType] - $ NormalC name [] - , entityFieldTHClause = - normalClause [conp name []] clause - } - -lookupEntityField - :: PersistEntity entity - => Proxy entity - -> FieldNameHS - -> FieldDef -lookupEntityField prxy fieldNameHS = - fromMaybe boom $ List.find ((fieldNameHS ==) . fieldHaskell) $ entityFields $ entityDef prxy - where - boom = - error "Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name" - -mkLookupEntityField - :: UnboundEntityDef - -> FieldNameHS - -> Q Exp -mkLookupEntityField ued ufd = - [| - lookupEntityField - (Proxy :: Proxy $(conT entityName)) - $(lift ufd) - |] - where - entityName = mkEntityNameHSName (getUnboundEntityNameHS ued) - -maybeNullable :: UnboundFieldDef -> Bool -maybeNullable fd = isUnboundFieldNullable fd == Nullable ByMaybeAttr - -ftToType :: FieldType -> Type -ftToType = \case - FTTypeCon Nothing t -> - ConT $ mkName $ T.unpack t - -- This type is generated from the Quasi-Quoter. - -- Adding this special case avoids users needing to import Data.Int - FTTypeCon (Just "Data.Int") "Int64" -> - ConT ''Int64 - FTTypeCon (Just m) t -> - ConT $ mkName $ unpack $ concat [m, ".", t] - FTLit l -> - LitT (typeLitToTyLit l) - FTTypePromoted t -> - PromotedT $ mkName $ T.unpack t - FTApp x y -> - ftToType x `AppT` ftToType y - FTList x -> - ListT `AppT` ftToType x - -typeLitToTyLit :: FieldTypeLit -> TyLit -typeLitToTyLit = \case - IntTypeLit n -> NumTyLit n - TextTypeLit t -> StrTyLit (T.unpack t) - -infixr 5 ++ -(++) :: Monoid m => m -> m -> m -(++) = mappend - -mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] -mkJSON _ def | ("json" `notElem` entityAttrs (unboundEntityDef def)) = return [] -mkJSON mps (fixEntityDef -> def) = do - requireExtensions [[FlexibleInstances]] - pureE <- [|pure|] - apE' <- [|(<*>)|] - - let objectE = VarE 'object - withObjectE = VarE 'withObject - dotEqualE = VarE '(.=) - dotColonE = VarE '(.:) - dotColonQE = VarE '(.:?) -#if MIN_VERSION_aeson(2,0,0) - toKeyE = VarE 'Key.fromString -#else - toKeyE = VarE 'pack -#endif - obj <- newName "obj" - let - fields = - getUnboundFieldDefs def - - xs <- mapM fieldToJSONValName fields - - let - conName = - mkEntityDefName def - typ = - genericDataType mps (entityHaskell (unboundEntityDef def)) backendT - toJSONI = - typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] - where - toJSON' = FunD 'toJSON $ return $ normalClause - [conp conName $ fmap VarP xs] - (objectE `AppE` ListE pairs) - where - pairs = zipWith toPair fields xs - toPair f x = InfixE - (Just (toKeyE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f))) - dotEqualE - (Just $ VarE x) - fromJSONI = - typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] - where - entNameStrLit = - StringL $ T.unpack (unEntityNameHS (getUnboundEntityNameHS def)) - parseJSONBody = - withObjectE `AppE` LitE entNameStrLit `AppE` decoderImpl - parseJSON' = - FunD 'parseJSON [ normalClause [] parseJSONBody ] - decoderImpl = - LamE [VarP obj] - (List.foldl' - (\x y -> InfixE (Just x) apE' (Just y)) - (pureE `AppE` ConE conName) - pulls - ) - where - pulls = - fmap toPull fields - toPull f = InfixE - (Just $ VarE obj) - (if maybeNullable f then dotColonQE else dotColonE) - (Just $ AppE toKeyE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f) - - case mpsEntityJSON mps of - Nothing -> - return [toJSONI, fromJSONI] - Just entityJSON -> do - entityJSONIs <- if mpsGeneric mps - then [d| - instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where - toJSON = $(varE (entityToJSON entityJSON)) - instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where - parseJSON = $(varE (entityFromJSON entityJSON)) - |] - else [d| - instance ToJSON (Entity $(pure typ)) where - toJSON = $(varE (entityToJSON entityJSON)) - instance FromJSON (Entity $(pure typ)) where - parseJSON = $(varE (entityFromJSON entityJSON)) - |] - return $ toJSONI : fromJSONI : entityJSONIs - -mkClassP :: Name -> [Type] -> Pred -mkClassP cla tys = List.foldl AppT (ConT cla) tys - -mkEqualP :: Type -> Type -> Pred -mkEqualP tleft tright = List.foldl AppT EqualityT [tleft, tright] - -notStrict :: Bang -notStrict = Bang NoSourceUnpackedness NoSourceStrictness - -isStrict :: Bang -isStrict = Bang NoSourceUnpackedness SourceStrict - -instanceD :: Cxt -> Type -> [Dec] -> Dec -instanceD = InstanceD Nothing - --- | Check that all of Persistent's required extensions are enabled, or else fail compilation --- --- This function should be called before any code that depends on one of the required extensions being enabled. -requirePersistentExtensions :: Q () -requirePersistentExtensions = requireExtensions requiredExtensions - where - requiredExtensions = fmap pure - [ DerivingStrategies - , GeneralizedNewtypeDeriving - , StandaloneDeriving - , UndecidableInstances - , MultiParamTypeClasses - ] - -mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] -mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do - let - entityHaskellName = - getEntityHaskellName $ unboundEntityDef ed - allFields = - getUnboundFieldDefs ed - mkEntityFieldConstr fieldHaskellName = - conE $ filterConName' mps entityHaskellName fieldHaskellName - :: Q Exp - regularFields <- forM (toList allFields) $ \fieldDef -> do - let - fieldHaskellName = - unboundFieldNameHS fieldDef - - let fieldNameT :: Q Type - fieldNameT = - litT $ strTyLit - $ T.unpack $ lowerFirstIfId - $ unFieldNameHS fieldHaskellName - - lowerFirstIfId "Id" = "id" - lowerFirstIfId xs = xs - - fieldTypeT - | fieldHaskellName == FieldNameHS "Id" = - conT ''Key `appT` recordNameT - | otherwise = - pure $ maybeIdType mps entityMap fieldDef Nothing Nothing - entityFieldConstr = - mkEntityFieldConstr fieldHaskellName - mkInstance fieldNameT fieldTypeT entityFieldConstr - - mkey <- do - let - fieldHaskellName = - FieldNameHS "Id" - entityFieldConstr = - mkEntityFieldConstr fieldHaskellName - fieldTypeT = - conT ''Key `appT` recordNameT - mkInstance [t|"id"|] fieldTypeT entityFieldConstr - - pure (mkey <> join regularFields) - where - nameG = - mkEntityDefGenericName ed - recordNameT - | mpsGeneric mps = - conT nameG `appT` varT backendName - | otherwise = - entityDefConT ed - mkInstance fieldNameT fieldTypeT entityFieldConstr = - [d| - instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where - symbolToField = $(entityFieldConstr) - |] - --- | Pass in a list of lists of extensions, where any of the given --- extensions will satisfy it. For example, you might need either GADTs or --- ExistentialQuantification, so you'd write: --- --- > requireExtensions [[GADTs, ExistentialQuantification]] --- --- But if you need TypeFamilies and MultiParamTypeClasses, then you'd --- write: --- --- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] -requireExtensions :: [[Extension]] -> Q () -requireExtensions requiredExtensions = do - -- isExtEnabled breaks the persistent-template benchmark with the following error: - -- Template Haskell error: Can't do `isExtEnabled' in the IO monad - -- You can workaround this by replacing isExtEnabled with (pure . const True) - unenabledExtensions <- filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions - - case mapMaybe listToMaybe unenabledExtensions of - [] -> pure () - [extension] -> fail $ mconcat - [ "Generating Persistent entities now requires the " - , show extension - , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n" - , extensionToPragma extension - ] - extensions -> fail $ mconcat - [ "Generating Persistent entities now requires the following language extensions:\n\n" - , List.intercalate "\n" (fmap show extensions) - , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" - , List.intercalate "\n" (fmap extensionToPragma extensions) - ] - - where - extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" - --- | creates a TH Name for use in the ToJSON instance -fieldToJSONValName :: UnboundFieldDef -> Q Name -fieldToJSONValName = - newName . T.unpack . unFieldNameHSForJSON . unboundFieldNameHS - --- | This special-cases "type_" and strips out its underscore. When --- used for JSON serialization and deserialization, it works around --- -unFieldNameHSForJSON :: FieldNameHS -> Text -unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS - where - fixTypeUnderscore = \case - "type" -> "type_" - name -> name - -entityDefConK :: UnboundEntityDef -> Kind -entityDefConK = conK . mkEntityDefName - -entityDefConT :: UnboundEntityDef -> Q Type -entityDefConT = pure . entityDefConK - -entityDefConE :: UnboundEntityDef -> Exp -entityDefConE = ConE . mkEntityDefName - --- | creates a TH Name for an entity's field, based on the entity --- name and the field name, so for example: --- --- Customer --- name Text --- --- This would generate `customerName` as a TH Name -fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name -fieldNameToRecordName mps entDef fieldName = - mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName - where - mUnderscore - | mpsGenerateLenses mps = Just "_" - | otherwise = Nothing - --- | as above, only takes a `FieldDef` -fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name -fieldDefToRecordName mps entDef fieldDef = - fieldNameToRecordName mps entDef (unboundFieldNameHS fieldDef) - --- | creates a TH Name for a lens on an entity's field, based on the entity --- name and the field name, so as above but for the Lens --- --- Customer --- name Text --- --- Generates a lens `customerName` when `mpsGenerateLenses` is true --- while `fieldNameToRecordName` generates a prefixed function --- `_customerName` -mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name -mkEntityLensName mps entDef fieldDef = - mkRecordName mps Nothing (entityHaskell (unboundEntityDef entDef)) (unboundFieldNameHS fieldDef) - -mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name -mkRecordName mps prefix entNameHS fieldNameHS = - mkName $ T.unpack . avoidKeyword $ fromMaybe "" prefix <> lowerFirst recName - where - recName :: Text - recName - | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) - | otherwise = fieldNameText - - entityNameText :: Text - entityNameText = - unEntityNameHS entNameHS - - fieldNameText :: Text - fieldNameText = - unFieldNameHS fieldNameHS - - avoidKeyword :: Text -> Text - avoidKeyword name = if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name - -haskellKeywords :: Set.Set Text -haskellKeywords = Set.fromList - ["case","class","data","default","deriving","do","else" - ,"if","import","in","infix","infixl","infixr","instance","let","module" - ,"newtype","of","then","type","where","_" - ,"foreign" - ] - --- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` -mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name] -mkEntityDefDeriveNames mps entDef = - let - entityInstances = - mkName . T.unpack <$> entityDerives (unboundEntityDef entDef) - additionalInstances = - filter (`notElem` entityInstances) $ mpsDeriveInstances mps - in - entityInstances <> additionalInstances - --- | Make a TH Name for the EntityDef's Haskell type -mkEntityNameHSName :: EntityNameHS -> Name -mkEntityNameHSName = - mkName . T.unpack . unEntityNameHS - --- | As above only taking an `EntityDef` -mkEntityDefName :: UnboundEntityDef -> Name -mkEntityDefName = - mkEntityNameHSName . entityHaskell . unboundEntityDef - --- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric -mkEntityDefGenericName :: UnboundEntityDef -> Name -mkEntityDefGenericName = - mkEntityNameHSGenericName . entityHaskell . unboundEntityDef - -mkEntityNameHSGenericName :: EntityNameHS -> Name -mkEntityNameHSGenericName name = - mkName $ T.unpack (unEntityNameHS name <> "Generic") - --- needs: --- --- * entityHaskell --- * field on EntityDef --- * fieldHaskell --- * field on FieldDef --- -sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name -sumConstrName mps entDef unboundFieldDef = - mkName $ T.unpack name - where - name - | mpsPrefixFields mps = modifiedName ++ "Sum" - | otherwise = fieldName ++ "Sum" - fieldNameHS = - unboundFieldNameHS unboundFieldDef - modifiedName = - mpsConstraintLabelModifier mps entityName fieldName - entityName = - unEntityNameHS $ getUnboundEntityNameHS entDef - fieldName = - upperFirst $ unFieldNameHS fieldNameHS - --- | Turn a ConstraintName into a TH Name -mkConstraintName :: ConstraintNameHS -> Name -mkConstraintName (ConstraintNameHS name) = - mkName (T.unpack name) - -keyIdName :: UnboundEntityDef -> Name -keyIdName = mkName . T.unpack . keyIdText - -keyIdText :: UnboundEntityDef -> Text -keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id" - -unKeyName :: UnboundEntityDef -> Name -unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef - -unKeyExp :: UnboundEntityDef -> Exp -unKeyExp ent = fieldSel (keyConName ent) (unKeyName ent) - -backendT :: Type -backendT = VarT backendName - -backendName :: Name -backendName = mkName "backend" - --- needs: --- --- * keyText --- * entityNameHaskell --- * fields --- * fieldHaskell --- --- keyConName :: EntityNameHS -> [FieldHaskell] -> Name -keyConName :: UnboundEntityDef -> Name -keyConName entDef = - keyConName' - (getUnboundEntityNameHS entDef) - (unboundFieldNameHS <$> unboundEntityFields (entDef)) - - -keyConName' :: EntityNameHS -> [FieldNameHS] -> Name -keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName - where - resolveConflict kn = if conflict then kn `mappend` "'" else kn - conflict = any (== FieldNameHS "key") entFields - --- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp -keyConExp :: UnboundEntityDef -> Exp -keyConExp ed = ConE $ keyConName ed - -keyText :: UnboundEntityDef -> Text -keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key" - -keyText' :: EntityNameHS -> Text -keyText' entName = unEntityNameHS entName ++ "Key" - -keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name -keyFieldName mps entDef fieldDef - | pkNewtype mps entDef = - unKeyName entDef - | otherwise = - mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` fieldName - where - fieldName = modifyFieldName (unFieldNameHS fieldDef) - modifyFieldName = - if mpsCamelCaseCompositeKeySelector mps then upperFirst else id - -filterConName - :: MkPersistSettings - -> UnboundEntityDef - -> UnboundFieldDef - -> Name -filterConName mps (unboundEntityDef -> entity) field = - filterConName' mps (entityHaskell entity) (unboundFieldNameHS field) - -filterConName' - :: MkPersistSettings - -> EntityNameHS - -> FieldNameHS - -> Name -filterConName' mps entity field = mkName $ T.unpack name - where - name - | field == FieldNameHS "Id" = entityName ++ fieldName - | mpsPrefixFields mps = modifiedName - | otherwise = fieldName - - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unEntityNameHS entity - fieldName = upperFirst $ unFieldNameHS field - -{-| -Splice in a list of all 'EntityDef' in scope. This is useful when running -'mkPersist' to ensure that all entity definitions are available for setting -foreign keys, and for performing migrations with all entities available. - -'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to -account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. - -For example, - -@ -share - [ mkPersistWith sqlSettings $(discoverEntities) - ] - [persistLowerCase| ... |] -@ - -Likewise, to run migrations with all entity instances in scope, you'd write: - -@ -migrateAll = migrateModels $(discoverEntities) -@ - -Note that there is some odd behavior with Template Haskell and splicing -groups. If you call 'discoverEntities' in the same module that defines -'PersistEntity' instances, you need to ensure they are in different top-level -binding groups. You can write @$(pure [])@ at the top level to do this. - -@ --- Foo and Bar both export an instance of PersistEntity -import Foo -import Bar - --- Since Foo and Bar are both imported, discoverEntities can find them here. -mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| - User - name Text - age Int - |] - --- onlyFooBar is defined in the same 'top level group' as the above generated --- instance for User, so it isn't present in this list. -onlyFooBar :: [EntityDef] -onlyFooBar = $(discoverEntities) - --- We can manually create a new binding group with this, which splices an --- empty list of declarations in. -$(pure []) - --- fooBarUser is able to see the 'User' instance. -fooBarUser :: [EntityDef] -fooBarUser = $(discoverEntities) -@ - -@since 2.13.0.0 --} -discoverEntities :: Q Exp -discoverEntities = do - instances <- reifyInstances ''PersistEntity [VarT (mkName "a")] - let - types = - mapMaybe getDecType instances - getDecType dec = - case dec of - InstanceD _moverlap [] typ _decs -> - stripPersistEntity typ - _ -> - Nothing - stripPersistEntity typ = - case typ of - AppT (ConT tyName) t | tyName == ''PersistEntity -> - Just t - _ -> - Nothing - - fmap ListE $ - forM types $ \typ -> do - [e| entityDef (Proxy :: Proxy $(pure typ)) |] - -setNull :: NonEmpty UnboundFieldDef -> Bool -setNull (fd :| fds) = - let - nullSetting = - isNull fd - isNull = - (NotNullable /=) . isUnboundFieldNullable - in - if all ((nullSetting ==) . isNull) fds - then nullSetting - else error $ - "foreign key columns must all be nullable or non-nullable" - ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd:fds)) +-- | This module provides the tools for defining your database schema and using +-- it to generate Haskell data types and migrations. +-- +-- For documentation on the domain specific language used for defining database +-- models, see "Database.Persist.Quasi". +-- +-- +module Database.Persist.TH + ( -- * Parse entity defs + persistWith + , persistUpperCase + , persistLowerCase + , persistFileWith + , persistManyFileWith + -- * Turn @EntityDef@s into types + , mkPersist + , mkPersistWith + -- ** Configuring Entity Definition + , MkPersistSettings + , mkPersistSettings + , sqlSettings + -- *** Record Fields (for update/viewing settings) + , mpsBackend + , mpsGeneric + , mpsPrefixFields + , mpsFieldLabelModifier + , mpsAvoidHsKeyword + , mpsConstraintLabelModifier + , mpsEntityHaddocks + , mpsEntityJSON + , mpsGenerateLenses + , mpsDeriveInstances + , mpsCamelCaseCompositeKeySelector + , EntityJSON(..) + -- ** Implicit ID Columns + , ImplicitIdDef + , setImplicitIdDef + -- * Various other TH functions + , mkMigrate + , migrateModels + , discoverEntities + , mkEntityDefList + , share + , derivePersistField + , derivePersistFieldJSON + , persistFieldFromEntity + ) where + +import Database.Persist.TH.Internal diff --git a/Database/Persist/TH/Internal.hs b/Database/Persist/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/TH/Internal.hs @@ -0,0 +1,3429 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module provides the tools for defining your database schema and using +-- it to generate Haskell data types and migrations. +-- +-- For documentation on the domain specific language used for defining database +-- models, see "Database.Persist.Quasi". +-- +-- +module Database.Persist.TH.Internal + ( -- * Parse entity defs + persistWith + , persistUpperCase + , persistLowerCase + , persistFileWith + , persistManyFileWith + -- * Turn @EntityDef@s into types + , mkPersist + , mkPersistWith + -- ** Configuring Entity Definition + , MkPersistSettings + , mkPersistSettings + , sqlSettings + -- *** Record Fields (for update/viewing settings) + , mpsBackend + , mpsGeneric + , mpsPrefixFields + , mpsFieldLabelModifier + , mpsAvoidHsKeyword + , mpsConstraintLabelModifier + , mpsEntityHaddocks + , mpsEntityJSON + , mpsGenerateLenses + , mpsDeriveInstances + , mpsCamelCaseCompositeKeySelector + , EntityJSON(..) + -- ** Implicit ID Columns + , ImplicitIdDef + , setImplicitIdDef + -- * Various other TH functions + , mkMigrate + , migrateModels + , discoverEntities + , mkEntityDefList + , share + , derivePersistField + , derivePersistFieldJSON + , persistFieldFromEntity + -- * Internal + , lensPTH + , parseReferences + , embedEntityDefs + , fieldError + , AtLeastOneUniqueKey(..) + , OnlyOneUniqueKey(..) + , pkNewtype + ) where + +-- Development Tip: See persistent-template/README.md for advice on seeing generated Template Haskell code +-- It's highly recommended to check the diff between master and your PR's generated code. + +import Prelude hiding (concat, exp, splitAt, take, (++)) + +import Control.Monad +import Data.Aeson + ( FromJSON(..) + , ToJSON(..) + , eitherDecodeStrict' + , object + , withObject + , (.:) + , (.:?) + , (.=) + ) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as Key +#endif +import qualified Data.ByteString as BS +import Data.Char (toLower, toUpper) +import Data.Coerce +import Data.Data (Data) +import Data.Either +import qualified Data.HashMap.Strict as HM +import Data.Int (Int64) +import Data.Ix (Ix) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as M +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) +import Data.Proxy (Proxy(Proxy)) +import Data.Text (Text, concat, cons, pack, stripSuffix, uncons, unpack) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) +import qualified Data.Text.Encoding as TE +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import GHC.TypeLits +import Instances.TH.Lift () + -- Bring `Lift (fmap k v)` instance into scope, as well as `Lift Text` + -- instance on pre-1.2.4 versions of `text` +import Data.Foldable (asum, toList) +import qualified Data.Set as Set +import Language.Haskell.TH.Lib + (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) +#if MIN_VERSION_template_haskell(2,21,0) +import Language.Haskell.TH.Lib (defaultBndrFlag) +#endif +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax +import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) +import Web.PathPieces (PathPiece(..)) + +import Database.Persist +import Database.Persist.Class.PersistEntity +import Database.Persist.Quasi +import Database.Persist.Quasi.Internal +import Database.Persist.Sql + (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) + +import Database.Persist.EntityDef.Internal (EntityDef(..)) +import Database.Persist.ImplicitIdDef (autoIncrementingInteger) +import Database.Persist.ImplicitIdDef.Internal + +#if MIN_VERSION_template_haskell(2,18,0) +conp :: Name -> [Pat] -> Pat +conp name pats = ConP name [] pats +#else +conp :: Name -> [Pat] -> Pat +conp = ConP +#endif + +-- | Converts a quasi-quoted syntax into a list of entity definitions, to be +-- used as input to the template haskell generation code (mkPersist). +persistWith :: PersistSettings -> QuasiQuoter +persistWith ps = QuasiQuoter + { quoteExp = \exp -> do + loc <- location + parseReferences ps [(Just $ sourceLocFromTHLoc loc, pack exp)] + , quotePat = + error "persistWith can't be used as pattern" + , quoteType = + error "persistWith can't be used as type" + , quoteDec = + error "persistWith can't be used as declaration" + } + +-- | Apply 'persistWith' to 'upperCaseSettings'. +persistUpperCase :: QuasiQuoter +persistUpperCase = persistWith upperCaseSettings + +-- | Apply 'persistWith' to 'lowerCaseSettings'. +persistLowerCase :: QuasiQuoter +persistLowerCase = persistWith lowerCaseSettings + +-- | Same as 'persistWith', but uses an external file instead of a +-- quasiquotation. The recommended file extension is @.persistentmodels@. +persistFileWith :: PersistSettings -> FilePath -> Q Exp +persistFileWith ps fp = persistManyFileWith ps [fp] + +-- | Same as 'persistFileWith', but uses several external files instead of +-- one. Splitting your Persistent definitions into multiple modules can +-- potentially dramatically speed up compile times. +-- +-- The recommended file extension is @.persistentmodels@. +-- +-- ==== __Examples__ +-- +-- Split your Persistent definitions into multiple files (@models1@, @models2@), +-- then create a new module for each new file and run 'mkPersist' there: +-- +-- @ +-- -- Model1.hs +-- 'share' +-- ['mkPersist' 'sqlSettings'] +-- $('persistFileWith' 'lowerCaseSettings' "models1") +-- @ +-- @ +-- -- Model2.hs +-- 'share' +-- ['mkPersist' 'sqlSettings'] +-- $('persistFileWith' 'lowerCaseSettings' "models2") +-- @ +-- +-- Use 'persistManyFileWith' to create your migrations: +-- +-- @ +-- -- Migrate.hs +-- 'mkMigrate' "migrateAll" +-- $('persistManyFileWith' 'lowerCaseSettings' ["models1.persistentmodels","models2.persistentmodels"]) +-- @ +-- +-- Tip: To get the same import behavior as if you were declaring all your models in +-- one file, import your new files @as Name@ into another file, then export @module Name@. +-- +-- This approach may be used in the future to reduce memory usage during compilation, +-- but so far we've only seen mild reductions. +-- +-- See and +-- for more details. +-- +-- @since 2.5.4 +persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp +persistManyFileWith ps fps = do + mapM_ qAddDependentFile fps + ss <- mapM (\fp -> (fp,) <$> (qRunIO . getFileContents) fp) fps + parseReferences ps (map (\(fp, content) -> (Just $ sourceLoc fp, content)) ss) + where + sourceLoc path = SourceLoc {locFile = T.pack path, locStartLine = 1, locStartCol = 1} + +getFileContents :: FilePath -> IO Text +getFileContents = fmap decodeUtf8 . BS.readFile + +-- | Takes a list of (potentially) independently defined entities and properly +-- links all foreign keys to reference the right 'EntityDef', tying the knot +-- between entities. +-- +-- Allows users to define entities indepedently or in separate modules and then +-- fix the cross-references between them at runtime to create a 'Migration'. +-- +-- @since 2.7.2 +embedEntityDefs + :: [EntityDef] + -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' + -- call. + -- + -- @since 2.13.0.0 + -> [UnboundEntityDef] + -> [UnboundEntityDef] +embedEntityDefs eds = snd . embedEntityDefsMap eds + +embedEntityDefsMap + :: [EntityDef] + -- ^ A list of 'EntityDef' that have been defined in a previous 'mkPersist' + -- call. + -- + -- @since 2.13.0.0 + -> [UnboundEntityDef] + -> (EmbedEntityMap, [UnboundEntityDef]) +embedEntityDefsMap existingEnts rawEnts = + (embedEntityMap, noCycleEnts) + where + noCycleEnts = entsWithEmbeds + embedEntityMap = constructEmbedEntityMap entsWithEmbeds + entsWithEmbeds = fmap setEmbedEntity (rawEnts <> map unbindEntityDef existingEnts) + setEmbedEntity ubEnt = + let + ent = unboundEntityDef ubEnt + in + ubEnt + { unboundEntityDef = + overEntityFields + (fmap (setEmbedField (entityHaskell ent) embedEntityMap)) + ent + } + + +-- | Calls 'parse' to Quasi.parse individual entities in isolation +-- afterwards, sets references to other entities +-- +-- In 2.13.0.0, this was changed to splice in @['UnboundEntityDef']@ +-- instead of @['EntityDef']@. +-- +-- @since 2.5.3 +parseReferences :: PersistSettings -> [(Maybe SourceLoc, Text)] -> Q Exp +parseReferences ps s = lift $ parse ps s + +preprocessUnboundDefs + :: [EntityDef] + -> [UnboundEntityDef] + -> (M.Map EntityNameHS (), [UnboundEntityDef]) +preprocessUnboundDefs preexistingEntities unboundDefs = + (embedEntityMap, noCycleEnts) + where + (embedEntityMap, noCycleEnts) = + embedEntityDefsMap preexistingEntities unboundDefs + +liftAndFixKeys + :: MkPersistSettings + -> M.Map EntityNameHS a + -> EntityMap + -> UnboundEntityDef + -> Q Exp +liftAndFixKeys mps emEntities entityMap unboundEnt = + let + ent = + unboundEntityDef unboundEnt + fields = + getUnboundFieldDefs unboundEnt + in + [| + ent + { entityFields = + $(ListE <$> traverse combinedFixFieldDef fields) + , entityId = + $(fixPrimarySpec mps unboundEnt) + , entityForeigns = + $(fixUnboundForeignDefs (unboundForeignDefs unboundEnt)) + } + |] + where + fixUnboundForeignDefs + :: [UnboundForeignDef] + -> Q Exp + fixUnboundForeignDefs fdefs = + fmap ListE $ forM fdefs fixUnboundForeignDef + where + fixUnboundForeignDef UnboundForeignDef{..} = + [| + unboundForeignDef + { foreignFields = + $(lift fixForeignFields) + , foreignNullable = + $(lift fixForeignNullable) + , foreignRefTableDBName = + $(lift fixForeignRefTableDBName) + } + |] + where + fixForeignRefTableDBName = + entityDB (unboundEntityDef parentDef) + foreignFieldNames = + case unboundForeignFields of + FieldListImpliedId ffns -> + ffns + FieldListHasReferences references -> + fmap ffrSourceField references + parentDef = + case M.lookup parentTableName entityMap of + Nothing -> + error $ mconcat + [ "Foreign table not defined: " + , show parentTableName + ] + Just a -> + a + parentTableName = + foreignRefTableHaskell unboundForeignDef + fixForeignFields :: [(ForeignFieldDef, ForeignFieldDef)] + fixForeignFields = + case unboundForeignFields of + FieldListImpliedId ffns -> + mkReferences $ toList ffns + FieldListHasReferences references -> + toList $ fmap convReferences references + where + -- in this case, we're up against the implied ID of the parent + -- dodgy assumption: columns are listed in the right order. we + -- can't check this any more clearly right now. + mkReferences fieldNames + | length fieldNames /= length parentKeyFieldNames = + error $ mconcat + [ "Foreign reference needs to have the same number " + , "of fields as the target table." + , "\n Table : " + , show (getUnboundEntityNameHS unboundEnt) + , "\n Foreign Table: " + , show parentTableName + , "\n Fields : " + , show fieldNames + , "\n Parent fields: " + , show (fmap fst parentKeyFieldNames) + , "\n\nYou can use the References keyword to fix this." + ] + | otherwise = + zip (fmap (withDbName fieldStore) fieldNames) (toList parentKeyFieldNames) + where + parentKeyFieldNames + :: NonEmpty (FieldNameHS, FieldNameDB) + parentKeyFieldNames = + case unboundPrimarySpec parentDef of + NaturalKey ucd -> + fmap (withDbName parentFieldStore) (unboundCompositeCols ucd) + SurrogateKey uid -> + pure (FieldNameHS "Id", unboundIdDBName uid) + DefaultKey dbName -> + pure (FieldNameHS "Id", dbName) + withDbName store fieldNameHS = + ( fieldNameHS + , findDBName store fieldNameHS + ) + convReferences + :: ForeignFieldReference + -> (ForeignFieldDef, ForeignFieldDef) + convReferences ForeignFieldReference {..} = + ( withDbName fieldStore ffrSourceField + , withDbName parentFieldStore ffrTargetField + ) + fixForeignNullable = + all ((NotNullable /=) . isForeignNullable) foreignFieldNames + where + isForeignNullable fieldNameHS = + case getFieldDef fieldNameHS fieldStore of + Nothing -> + error "Field name not present in map" + Just a -> + isUnboundFieldNullable a + + fieldStore = + mkFieldStore unboundEnt + parentFieldStore = + mkFieldStore parentDef + findDBName store fieldNameHS = + case getFieldDBName fieldNameHS store of + Nothing -> + error $ mconcat + [ "findDBName: failed to fix dbname for: " + , show fieldNameHS + ] + Just a-> + a + + combinedFixFieldDef :: UnboundFieldDef -> Q Exp + combinedFixFieldDef ufd@UnboundFieldDef{..} = + [| + FieldDef + { fieldHaskell = + unboundFieldNameHS + , fieldDB = + unboundFieldNameDB + , fieldType = + unboundFieldType + , fieldSqlType = + $(sqlTyp') + , fieldAttrs = + unboundFieldAttrs + , fieldStrict = + unboundFieldStrict + , fieldReference = + $(fieldRef') + , fieldCascade = + unboundFieldCascade + , fieldComments = + unboundFieldComments + , fieldGenerated = + unboundFieldGenerated + , fieldIsImplicitIdColumn = + False + } + |] + where + sqlTypeExp = + getSqlType emEntities entityMap ufd + FieldDef _x _ _ _ _ _ _ _ _ _ _ = + error "need to update this record wildcard match" + (fieldRef', sqlTyp') = + case extractForeignRef entityMap ufd of + Just targetTable -> + let targetTableQualified = + fromMaybe targetTable (guessFieldReferenceQualified ufd) + in (lift (ForeignRef targetTable), liftSqlTypeExp (SqlTypeReference targetTableQualified)) + Nothing -> + (lift NoReference, liftSqlTypeExp sqlTypeExp) + +data FieldStore + = FieldStore + { fieldStoreMap :: M.Map FieldNameHS UnboundFieldDef + , fieldStoreId :: Maybe FieldNameDB + , fieldStoreEntity :: UnboundEntityDef + } + +mkFieldStore :: UnboundEntityDef -> FieldStore +mkFieldStore ued = + FieldStore + { fieldStoreEntity = ued + , fieldStoreMap = + M.fromList + $ fmap (\ufd -> + ( unboundFieldNameHS ufd + , ufd + ) + ) + $ getUnboundFieldDefs + $ ued + , fieldStoreId = + case unboundPrimarySpec ued of + NaturalKey _ -> + Nothing + SurrogateKey fd -> + Just $ unboundIdDBName fd + DefaultKey n -> + Just n + } + +getFieldDBName :: FieldNameHS -> FieldStore -> Maybe FieldNameDB +getFieldDBName name fs + | FieldNameHS "Id" == name = + fieldStoreId fs + | otherwise = + unboundFieldNameDB <$> getFieldDef name fs + +getFieldDef :: FieldNameHS -> FieldStore -> Maybe UnboundFieldDef +getFieldDef fieldNameHS fs = + M.lookup fieldNameHS (fieldStoreMap fs) + +extractForeignRef :: EntityMap -> UnboundFieldDef -> Maybe EntityNameHS +extractForeignRef entityMap fieldDef = do + refName <- guessFieldReference fieldDef + ent <- M.lookup refName entityMap + pure $ entityHaskell $ unboundEntityDef ent + +guessFieldReference :: UnboundFieldDef -> Maybe EntityNameHS +guessFieldReference = guessReference . unboundFieldType + +guessReference :: FieldType -> Maybe EntityNameHS +guessReference ft = + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon _ (checkIdSuffix -> Just tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ tableName) <- mft + pure tableName + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] + +guessFieldReferenceQualified :: UnboundFieldDef -> Maybe EntityNameHS +guessFieldReferenceQualified = guessReferenceQualified . unboundFieldType + +guessReferenceQualified :: FieldType -> Maybe EntityNameHS +guessReferenceQualified ft = + EntityNameHS <$> guessReferenceText (Just ft) + where + checkIdSuffix = + T.stripSuffix "Id" + guessReferenceText mft = + asum + [ do + FTTypeCon mmod (checkIdSuffix -> Just tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon mmod tableName) <- mft + -- handle qualified name. + pure $ maybe tableName (\qualName -> qualName <> "." <> tableName) mmod + , do + FTApp (FTTypeCon _ "Maybe") next <- mft + guessReferenceText (Just next) + ] + +mkDefaultKey + :: MkPersistSettings + -> FieldNameDB + -> EntityNameHS + -> FieldDef +mkDefaultKey mps pk unboundHaskellName = + let + iid = + mpsImplicitIdDef mps + in + maybe id addFieldAttr (FieldAttrDefault <$> iidDefault iid) $ + maybe id addFieldAttr (FieldAttrMaxlen <$> iidMaxLen iid) $ + mkAutoIdField' pk unboundHaskellName (iidFieldSqlType iid) + +fixPrimarySpec + :: MkPersistSettings + -> UnboundEntityDef + -> Q Exp +fixPrimarySpec mps unboundEnt= do + case unboundPrimarySpec unboundEnt of + DefaultKey pk -> + lift $ EntityIdField $ + mkDefaultKey mps pk unboundHaskellName + SurrogateKey uid -> do + let + entNameHS = + getUnboundEntityNameHS unboundEnt + fieldTyp = + fromMaybe (mkKeyConType entNameHS) (unboundIdType uid) + [| + EntityIdField + FieldDef + { fieldHaskell = + FieldNameHS "Id" + , fieldDB = + $(lift $ getSqlNameOr (unboundIdDBName uid) (unboundIdAttrs uid)) + , fieldType = + $(lift fieldTyp) + , fieldSqlType = + $( liftSqlTypeExp (SqlTypeExp fieldTyp) ) + , fieldStrict = + False + , fieldReference = + ForeignRef entNameHS + , fieldAttrs = + unboundIdAttrs uid + , fieldComments = + Nothing + , fieldCascade = unboundIdCascade uid + , fieldGenerated = Nothing + , fieldIsImplicitIdColumn = True + } + + |] + NaturalKey ucd -> + [| EntityIdNaturalKey $(bindCompositeDef unboundEnt ucd) |] + where + unboundHaskellName = + getUnboundEntityNameHS unboundEnt + +bindCompositeDef :: UnboundEntityDef -> UnboundCompositeDef -> Q Exp +bindCompositeDef ued ucd = do + fieldDefs <- + fmap ListE $ forM (toList $ unboundCompositeCols ucd) $ \col -> + mkLookupEntityField ued col + [| + CompositeDef + { compositeFields = + NEL.fromList $(pure fieldDefs) + , compositeAttrs = + $(lift $ unboundCompositeAttrs ucd) + } + |] + +getSqlType :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp +getSqlType emEntities entityMap field = + maybe + (defaultSqlTypeExp emEntities entityMap field) + (SqlType' . SqlOther) + (listToMaybe $ mapMaybe attrSqlType $ unboundFieldAttrs field) + +-- In the case of embedding, there won't be any datatype created yet. +-- We just use SqlString, as the data will be serialized to JSON. +defaultSqlTypeExp :: M.Map EntityNameHS a -> EntityMap -> UnboundFieldDef -> SqlTypeExp +defaultSqlTypeExp emEntities entityMap field = + case mEmbedded emEntities ftype of + Right _ -> + SqlType' SqlString + Left (Just (FTKeyCon ty)) -> + SqlTypeExp (FTTypeCon Nothing ty) + Left Nothing -> + case extractForeignRef entityMap field of + Just refName -> + case M.lookup refName entityMap of + Nothing -> + -- error $ mconcat + -- [ "Failed to find model: " + -- , show refName + -- , " in entity list: \n" + -- ] + -- <> (unlines $ map show $ M.keys $ entityMap) + -- going to assume that it's fine, will reify it out + -- right later anyway) + SqlTypeExp ftype + -- A ForeignRef is blindly set to an Int64 in setEmbedField + -- correct that now + Just _ -> + SqlTypeReference refName + _ -> + case ftype of + -- In the case of lists, we always serialize to a string + -- value (via JSON). + -- + -- Normally, this would be determined automatically by + -- SqlTypeExp. However, there's one corner case: if there's + -- a list of entity IDs, the datatype for the ID has not + -- yet been created, so the compiler will fail. This extra + -- clause works around this limitation. + FTList _ -> + SqlType' SqlString + _ -> + SqlTypeExp ftype + where + ftype = unboundFieldType field + +attrSqlType :: FieldAttr -> Maybe Text +attrSqlType = \case + FieldAttrSqltype x -> Just x + _ -> Nothing + +data SqlTypeExp + = SqlTypeExp FieldType + | SqlType' SqlType + | SqlTypeReference EntityNameHS + deriving Show + +liftSqlTypeExp :: SqlTypeExp -> Q Exp +liftSqlTypeExp ste = + case ste of + SqlType' t -> + lift t + SqlTypeExp ftype -> do + let + typ = ftToType ftype + mtyp = ConT ''Proxy `AppT` typ + typedNothing = SigE (ConE 'Proxy) mtyp + pure $ VarE 'sqlType `AppE` typedNothing + SqlTypeReference entNameHs -> do + let + entNameId :: Name + entNameId = + mkName $ T.unpack (unEntityNameHS entNameHs) <> "Id" + + [| sqlType (Proxy :: Proxy $(conT entNameId)) |] + + +type EmbedEntityMap = M.Map EntityNameHS () + +constructEmbedEntityMap :: [UnboundEntityDef] -> EmbedEntityMap +constructEmbedEntityMap = + M.fromList . fmap + (\ent -> + ( entityHaskell (unboundEntityDef ent) + -- , toEmbedEntityDef (unboundEntityDef ent) + , () + ) + ) + +lookupEmbedEntity :: M.Map EntityNameHS a -> FieldDef -> Maybe EntityNameHS +lookupEmbedEntity allEntities field = do + let mfieldTy = Just $ fieldType field + entName <- EntityNameHS <$> asum + [ do + FTTypeCon _ t <- mfieldTy + stripSuffix "Id" t + , do + FTApp (FTTypeCon _ "Key") (FTTypeCon _ entName) <- mfieldTy + pure entName + , do + FTApp (FTTypeCon _ "Maybe") (FTTypeCon _ t) <- mfieldTy + stripSuffix "Id" t + ] + guard (M.member entName allEntities) -- check entity name exists in embed fmap + pure entName + +type EntityMap = M.Map EntityNameHS UnboundEntityDef + +constructEntityMap :: [UnboundEntityDef] -> EntityMap +constructEntityMap = + M.fromList . fmap (\ent -> (entityHaskell (unboundEntityDef ent), ent)) + +data FTTypeConDescr = FTKeyCon Text + deriving Show + +-- | Recurses through the 'FieldType'. Returns a 'Right' with the +-- 'EmbedEntityDef' if the 'FieldType' corresponds to an unqualified use of +-- a name and that name is present in the 'EmbedEntityMap' provided as +-- a first argument. +-- +-- If the 'FieldType' represents a @Key something@, this returns a @'Left +-- ('Just' 'FTKeyCon')@. +-- +-- If the 'FieldType' has a module qualified value, then it returns @'Left' +-- 'Nothing'@. +mEmbedded + :: M.Map EntityNameHS a + -> FieldType + -> Either (Maybe FTTypeConDescr) EntityNameHS +mEmbedded _ (FTTypeCon Just{} _) = + Left Nothing +mEmbedded ents (FTTypeCon Nothing (EntityNameHS -> name)) = + maybe (Left Nothing) (\_ -> Right name) $ M.lookup name ents +mEmbedded _ (FTTypePromoted _) = + Left Nothing +mEmbedded ents (FTList x) = + mEmbedded ents x +mEmbedded _ (FTApp (FTTypeCon Nothing "Key") (FTTypeCon _ a)) = + Left $ Just $ FTKeyCon $ a <> "Id" +mEmbedded _ (FTApp _ _) = + Left Nothing +mEmbedded _ (FTLit _) = + Left Nothing + +setEmbedField :: EntityNameHS -> M.Map EntityNameHS a -> FieldDef -> FieldDef +setEmbedField entName allEntities field = + case fieldReference field of + NoReference -> + setFieldReference ref field + _ -> + field + where + ref = + case mEmbedded allEntities (fieldType field) of + Left _ -> fromMaybe NoReference $ do + refEntName <- lookupEmbedEntity allEntities field + pure $ ForeignRef refEntName + Right em -> + if em /= entName + then EmbedRef em + else if maybeNullable (unbindFieldDef field) + then SelfReference + else case fieldType field of + FTList _ -> SelfReference + _ -> error $ unpack $ unEntityNameHS entName <> ": a self reference must be a Maybe or List" + +setFieldReference :: ReferenceDef -> FieldDef -> FieldDef +setFieldReference ref field = field { fieldReference = ref } + +-- | Create data types and appropriate 'PersistEntity' instances for the given +-- 'UnboundEntityDef's. +-- +-- This function should be used if you are only defining a single block of +-- Persistent models for the entire application. If you intend on defining +-- multiple blocks in different fiels, see 'mkPersistWith' which allows you +-- to provide existing entity definitions so foreign key references work. +-- +-- Example: +-- +-- @ +-- mkPersist 'sqlSettings' ['persistLowerCase'| +-- User +-- name Text +-- age Int +-- +-- Dog +-- name Text +-- owner UserId +-- +-- |] +-- @ +-- +-- Example from a file: +-- +-- @ +-- mkPersist 'sqlSettings' $('persistFileWith' 'lowerCaseSettings' "models.persistentmodels") +-- @ +-- +-- For full information on the 'QuasiQuoter' syntax, see +-- "Database.Persist.Quasi" documentation. +mkPersist + :: MkPersistSettings + -> [UnboundEntityDef] + -> Q [Dec] +mkPersist mps = mkPersistWith mps [] + +-- | Like 'mkPersist', but allows you to provide a @['EntityDef']@ +-- representing the predefined entities. This function will include those +-- 'EntityDef' when looking for foreign key references. +-- +-- You should use this if you intend on defining Persistent models in +-- multiple files. +-- +-- Suppose we define a table @Foo@ which has no dependencies. +-- +-- @ +-- module DB.Foo where +-- +-- 'mkPersistWith' 'sqlSettings' [] ['persistLowerCase'| +-- Foo +-- name Text +-- |] +-- @ +-- +-- Then, we define a table @Bar@ which depends on @Foo@: +-- +-- @ +-- module DB.Bar where +-- +-- import DB.Foo +-- +-- 'mkPersistWith' 'sqlSettings' [entityDef (Proxy :: Proxy Foo)] ['persistLowerCase'| +-- Bar +-- fooId FooId +-- |] +-- @ +-- +-- Writing out the list of 'EntityDef' can be annoying. The +-- @$('discoverEntities')@ shortcut will work to reduce this boilerplate. +-- +-- @ +-- module DB.Quux where +-- +-- import DB.Foo +-- import DB.Bar +-- +-- 'mkPersistWith' 'sqlSettings' $('discoverEntities') ['persistLowerCase'| +-- Quux +-- name Text +-- fooId FooId +-- barId BarId +-- |] +-- @ +-- +-- @since 2.13.0.0 +mkPersistWith + :: MkPersistSettings + -> [EntityDef] + -> [UnboundEntityDef] + -> Q [Dec] +mkPersistWith mps preexistingEntities ents' = do + let + (embedEntityMap, predefs) = + preprocessUnboundDefs preexistingEntities ents' + allEnts = + embedEntityDefs preexistingEntities + $ fmap (setDefaultIdFields mps) + $ predefs + entityMap = + constructEntityMap allEnts + preexistingSet = + Set.fromList $ map getEntityHaskellName preexistingEntities + newEnts = + filter + (\e -> getUnboundEntityNameHS e `Set.notMember` preexistingSet) + allEnts + ents <- filterM shouldGenerateCode newEnts + requireExtensions + [ [TypeFamilies], [GADTs, ExistentialQuantification] + , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] + , [UndecidableInstances], [DataKinds], [FlexibleInstances] + ] + persistFieldDecs <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents + entityDecs <- fmap mconcat $ mapM (mkEntity embedEntityMap entityMap mps) ents + jsonDecs <- fmap mconcat $ mapM (mkJSON mps) ents + uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents + safeToInsertInstances <- mconcat <$> mapM (mkSafeToInsertInstance mps) ents + symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps entityMap) ents + return $ mconcat + [ persistFieldDecs + , entityDecs + , jsonDecs + , uniqueKeyInstances + , symbolToFieldInstances + , safeToInsertInstances + ] + +mkSafeToInsertInstance :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkSafeToInsertInstance mps ued = + case unboundPrimarySpec ued of + NaturalKey _ -> + instanceOkay + SurrogateKey uidDef -> do + let attrs = + unboundIdAttrs uidDef + isDefaultFieldAttr = \case + FieldAttrDefault _ -> + True + _ -> + False + case unboundIdType uidDef of + Nothing -> + instanceOkay + Just _ -> + case List.find isDefaultFieldAttr attrs of + Nothing -> + badInstance + Just _ -> do + instanceOkay + + DefaultKey _ -> + instanceOkay + + where + typ :: Type + typ = genericDataType mps (getUnboundEntityNameHS ued) backendT + + mkInstance merr = + InstanceD Nothing (maybe id (:) merr withPersistStoreWriteCxt) (ConT ''SafeToInsert `AppT` typ) [] + instanceOkay = + pure + [ mkInstance Nothing + ] + badInstance = do + err <- [t| TypeError (SafeToInsertErrorMessage $(pure typ)) |] + pure + [ mkInstance (Just err) + ] + + withPersistStoreWriteCxt = + if mpsGeneric mps + then + [ConT ''PersistStoreWrite `AppT` backendT] + else + [] + + +-- we can't just use 'isInstance' because TH throws an error +shouldGenerateCode :: UnboundEntityDef -> Q Bool +shouldGenerateCode ed = do + mtyp <- lookupTypeName entityName + case mtyp of + Nothing -> do + pure True + Just typeName -> do + instanceExists <- isInstance ''PersistEntity [ConT typeName] + pure (not instanceExists) + where + entityName = + T.unpack . unEntityNameHS . getEntityHaskellName . unboundEntityDef $ ed + +overEntityDef :: (EntityDef -> EntityDef) -> UnboundEntityDef -> UnboundEntityDef +overEntityDef f ued = ued { unboundEntityDef = f (unboundEntityDef ued) } + +setDefaultIdFields :: MkPersistSettings -> UnboundEntityDef -> UnboundEntityDef +setDefaultIdFields mps ued + | defaultIdType ued = + overEntityDef + (setEntityIdDef (setToMpsDefault (mpsImplicitIdDef mps) (getEntityId ed))) + ued + | otherwise = + ued + where + ed = + unboundEntityDef ued + setToMpsDefault :: ImplicitIdDef -> EntityIdDef -> EntityIdDef + setToMpsDefault iid (EntityIdField fd) = + EntityIdField fd + { fieldType = + iidFieldType iid (getEntityHaskellName ed) + , fieldSqlType = + iidFieldSqlType iid + , fieldAttrs = + let + def = + toList (FieldAttrDefault <$> iidDefault iid) + maxlen = + toList (FieldAttrMaxlen <$> iidMaxLen iid) + in + def <> maxlen <> fieldAttrs fd + , fieldIsImplicitIdColumn = + True + } + setToMpsDefault _ x = + x + +-- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. +-- For example, strip out any fields marked as MigrationOnly. +-- +-- This should be called when performing Haskell codegen, but the 'EntityDef' +-- *should* keep all of the fields present when defining 'entityDef'. This is +-- necessary so that migrations know to keep these columns around, or to delete +-- them, as appropriate. +fixEntityDef :: UnboundEntityDef -> UnboundEntityDef +fixEntityDef ued = + ued + { unboundEntityFields = + filter isHaskellUnboundField (unboundEntityFields ued) + } + +-- | Settings to be passed to the 'mkPersist' function. +data MkPersistSettings = MkPersistSettings + { mpsBackend :: Type + -- ^ Which database backend we\'re using. This type is used for the + -- 'PersistEntityBackend' associated type in the entities that are + -- generated. + -- + -- If the 'mpsGeneric' value is set to 'True', then this type is used for + -- the non-Generic type alias. The data and type will be named: + -- + -- @ + -- data ModelGeneric backend = Model { ... } + -- @ + -- + -- And, for convenience's sake, we provide a type alias: + -- + -- @ + -- type Model = ModelGeneric $(the type you give here) + -- @ + , mpsGeneric :: Bool + -- ^ Create generic types that can be used with multiple backends. Good for + -- reusable code, but makes error messages harder to understand. Default: + -- False. + , mpsPrefixFields :: Bool + -- ^ Prefix field names with the model name. Default: True. + -- + -- Note: this field is deprecated. Use the mpsFieldLabelModifier and + -- 'mpsConstraintLabelModifier' instead. + , mpsFieldLabelModifier :: Text -> Text -> Text + -- ^ Customise the field accessors and lens names using the entity and field + -- name. Both arguments are upper cased. + -- + -- Default: appends entity and field. + -- + -- Note: this setting is ignored if mpsPrefixFields is set to False. + -- + -- @since 2.11.0.0 + , mpsAvoidHsKeyword :: Text -> Text + -- ^ Customise function for field accessors applied only when the field name matches any of Haskell keywords. + -- + -- Default: suffix "_". + -- + -- @since 2.14.6.0 + , mpsConstraintLabelModifier :: Text -> Text -> Text + -- ^ Customise the Constraint names using the entity and field name. The + -- result should be a valid haskell type (start with an upper cased letter). + -- + -- Default: appends entity and field + -- + -- Note: this setting is ignored if mpsPrefixFields is set to False. + -- + -- @since 2.11.0.0 + , mpsEntityHaddocks :: Bool + -- ^ Generate Haddocks from entity documentation comments. Default: False. + -- + -- @since 2.14.6.0 + , mpsEntityJSON :: Maybe EntityJSON + -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's + -- @Nothing@, no instances will be generated. Default: + -- + -- @ + -- Just 'EntityJSON' + -- { 'entityToJSON' = 'entityIdToJSON + -- , 'entityFromJSON' = 'entityIdFromJSON + -- } + -- @ + , mpsGenerateLenses :: Bool + -- ^ Instead of generating normal field accessors, generator lens-style + -- accessors. + -- + -- Default: False + -- + -- @since 1.3.1 + , mpsDeriveInstances :: [Name] + -- ^ Automatically derive these typeclass instances for all record and key + -- types. + -- + -- Default: [] + -- + -- @since 2.8.1 + , mpsImplicitIdDef :: ImplicitIdDef + -- ^ TODO: document + -- + -- @since 2.13.0.0 + , mpsCamelCaseCompositeKeySelector :: Bool + -- ^ Should we generate composite key accessors in the correct CamelCase style. + -- + -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'False', + -- then the field part of the accessor starts with the lowercase. + -- This is a legacy style. + -- + -- @ + -- data Key CompanyUser = CompanyUserKey + -- { companyUserKeycompanyId :: CompanyId + -- , companyUserKeyuserId :: UserId + -- } + -- @ + -- + -- If the 'mpsCamelCaseCompositeKeySelector' value is set to 'True', + -- then field accessors are generated in CamelCase style. + -- + -- @ + -- data Key CompanyUser = CompanyUserKey + -- { companyUserKeyCompanyId :: CompanyId + -- , companyUserKeyUserId :: UserId + -- } + -- @ + + -- Default: False + -- + -- @since 2.14.2.0 + } + +{-# DEPRECATED mpsGeneric "The mpsGeneric function adds a considerable amount of overhead and complexity to the library without bringing significant benefit. We would like to remove it. If you require this feature, please comment on the linked GitHub issue, and we'll either keep it around, or we can figure out a nicer way to solve your problem.\n\n Github: https://github.com/yesodweb/persistent/issues/1204" #-} + +-- | Set the 'ImplicitIdDef' in the given 'MkPersistSettings'. The default +-- value is 'autoIncrementingInteger'. +-- +-- @since 2.13.0.0 +setImplicitIdDef :: ImplicitIdDef -> MkPersistSettings -> MkPersistSettings +setImplicitIdDef iid mps = + mps { mpsImplicitIdDef = iid } + +getImplicitIdType :: MkPersistSettings -> Type +getImplicitIdType = do + idDef <- mpsImplicitIdDef + isGeneric <- mpsGeneric + backendTy <- mpsBackend + pure $ iidType idDef isGeneric backendTy + +data EntityJSON = EntityJSON + { entityToJSON :: Name + -- ^ Name of the @toJSON@ implementation for @Entity a@. + , entityFromJSON :: Name + -- ^ Name of the @fromJSON@ implementation for @Entity a@. + } + +-- | Create an @MkPersistSettings@ with default values. +mkPersistSettings + :: Type -- ^ Value for 'mpsBackend' + -> MkPersistSettings +mkPersistSettings backend = MkPersistSettings + { mpsBackend = backend + , mpsGeneric = False + , mpsPrefixFields = True + , mpsFieldLabelModifier = (++) + , mpsAvoidHsKeyword = (++ "_") + , mpsConstraintLabelModifier = (++) + , mpsEntityHaddocks = False + , mpsEntityJSON = Just EntityJSON + { entityToJSON = 'entityIdToJSON + , entityFromJSON = 'entityIdFromJSON + } + , mpsGenerateLenses = False + , mpsDeriveInstances = [] + , mpsImplicitIdDef = + autoIncrementingInteger + , mpsCamelCaseCompositeKeySelector = False + } + +-- | Use the 'SqlPersist' backend. +sqlSettings :: MkPersistSettings +sqlSettings = mkPersistSettings $ ConT ''SqlBackend + +lowerFirst :: Text -> Text +lowerFirst t = + case uncons t of + Just (a, b) -> cons (toLower a) b + Nothing -> t + +upperFirst :: Text -> Text +upperFirst t = + case uncons t of + Just (a, b) -> cons (toUpper a) b + Nothing -> t + +dataTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q Dec +dataTypeDec mps entityMap entDef = do + let + names = + mkEntityDefDeriveNames mps entDef + + let (stocks, anyclasses) = partitionEithers (fmap stratFor names) + let stockDerives = do + guard (not (null stocks)) + pure (DerivClause (Just StockStrategy) (fmap ConT stocks)) + anyclassDerives = do + guard (not (null anyclasses)) + pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses)) + unless (null anyclassDerives) $ do + requireExtensions [[DeriveAnyClass]] + let dec = DataD [] nameFinal paramsFinal + Nothing + constrs + (stockDerives <> anyclassDerives) +#if MIN_VERSION_template_haskell(2,18,0) + when (mpsEntityHaddocks mps) $ do + forM_ cols $ \((name, _, _), maybeComments) -> do + case maybeComments of + Just comment -> addModFinalizer $ + putDoc (DeclDoc name) (unpack comment) + Nothing -> pure () + case entityComments (unboundEntityDef entDef) of + Just doc -> do + addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc) + _ -> pure () +#endif + pure dec + + where + stratFor n = + if n `elem` stockClasses then + Left n + else + Right n + + stockClasses = + Set.fromList (fmap mkName + [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable" + ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable + ] + ) + + (nameFinal, paramsFinal) + | mpsGeneric mps = + ( mkEntityDefGenericName entDef + , [ mkPlainTV backendName + ] + ) + + | otherwise = + (mkEntityDefName entDef, []) + + cols :: [(VarBangType, Maybe Text)] + cols = do + fieldDef <- getUnboundFieldDefs entDef + let + recordNameE = + fieldDefToRecordName mps entDef fieldDef + strictness = + if unboundFieldStrict fieldDef + then isStrict + else notStrict + fieldIdType = + maybeIdType mps entityMap fieldDef Nothing Nothing + fieldComments = + unboundFieldComments fieldDef + pure ((recordNameE, strictness, fieldIdType), fieldComments) + + constrs + | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef + | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)] + + sumCon fieldDef = NormalC + (sumConstrName mps entDef fieldDef) + [(notStrict, maybeIdType mps entityMap fieldDef Nothing Nothing)] + +uniqueTypeDec :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Dec +uniqueTypeDec mps entityMap entDef = + DataInstD + [] +#if MIN_VERSION_template_haskell(2,15,0) + Nothing + (AppT (ConT ''Unique) (genericDataType mps (getUnboundEntityNameHS entDef) backendT)) +#else + ''Unique + [genericDataType mps (getUnboundEntityNameHS entDef) backendT] +#endif + Nothing + (fmap (mkUnique mps entityMap entDef) $ entityUniques (unboundEntityDef entDef)) + [] + +mkUnique :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UniqueDef -> Con +mkUnique mps entityMap entDef (UniqueDef constr _ fields attrs) = + NormalC (mkConstraintName constr) $ toList types + where + types = + fmap (go . flip lookup3 (getUnboundFieldDefs entDef) . unFieldNameHS . fst) fields + + force = "!force" `elem` attrs + + go :: (UnboundFieldDef, IsNullable) -> (Strict, Type) + go (_, Nullable _) | not force = error nullErrMsg + go (fd, y) = (notStrict, maybeIdType mps entityMap fd Nothing (Just y)) + + lookup3 :: Text -> [UnboundFieldDef] -> (UnboundFieldDef, IsNullable) + lookup3 s [] = + error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr + lookup3 x (fd:rest) + | x == unFieldNameHS (unboundFieldNameHS fd) = + (fd, isUnboundFieldNullable fd) + | otherwise = + lookup3 x rest + + nullErrMsg = + mconcat [ "Error: By default Persistent disallows NULLables in an uniqueness " + , "constraint. The semantics of how NULL interacts with those constraints " + , "is non-trivial: most SQL implementations will not consider two NULL " + , "values to be equal for the purposes of an uniqueness constraint, " + , "allowing insertion of more than one row with a NULL value for the " + , "column in question. If you understand this feature of SQL and still " + , "intend to add a uniqueness constraint here, *** Use a \"!force\" " + , "attribute on the end of the line that defines your uniqueness " + , "constraint in order to disable this check. ***" ] + +-- | This function renders a Template Haskell 'Type' for an 'UnboundFieldDef'. +-- It takes care to respect the 'mpsGeneric' setting to render an Id faithfully, +-- and it also ensures that the generated Haskell type is 'Maybe' if the +-- database column has that attribute. +-- +-- For a database schema with @'mpsGeneric' = False@, this is simple - it uses +-- the @ModelNameId@ type directly. This resolves just fine. +-- +-- If 'mpsGeneric' is @True@, then we have to do something a bit more +-- complicated. We can't refer to a @ModelNameId@ directly, because that @Id@ +-- alias hides the backend type variable. Instead, we need to refer to: +-- +-- > Key (ModelNameGeneric backend) +-- +-- This means that the client code will need both the term @ModelNameId@ in +-- scope, as well as the @ModelNameGeneric@ constructor, despite the fact that +-- the @ModelNameId@ is the only term explicitly used (and imported). +-- +-- However, we're not guaranteed to have @ModelName@ in scope - we've only +-- referenced @ModelNameId@ in code, and so code generation *should* work even +-- without this. Consider an explicit-style import: +-- +-- @ +-- import Model.Foo (FooId) +-- +-- mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| +-- Bar +-- foo FooId +-- |] +-- @ +-- +-- This looks like it ought to work, but it would fail with @mpsGeneric@ being +-- enabled. One hacky work-around is to perform a @'lookupTypeName' :: String -> +-- Q (Maybe Name)@ on the @"ModelNameId"@ type string. If the @Id@ is +-- a reference in the 'EntityMap' and @lookupTypeName@ returns @'Just' name@, +-- then that 'Name' contains the fully qualified information needed to use the +-- 'Name' without importing it at the client-site. Then we can perform a bit of +-- surgery on the 'Name' to strip the @Id@ suffix, turn it into a 'Type', and +-- apply the 'Key' constructor. +maybeIdType + :: MkPersistSettings + -> EntityMap + -> UnboundFieldDef + -> Maybe Name -- ^ backend + -> Maybe IsNullable + -> Type +maybeIdType mps entityMap fieldDef mbackend mnull = + maybeTyp mayNullable idType + where + mayNullable = + case mnull of + Just (Nullable ByMaybeAttr) -> + True + _ -> + maybeNullable fieldDef + idType = + fromMaybe (ftToType $ unboundFieldType fieldDef) $ do + typ <- extractForeignRef entityMap fieldDef + guard ((mpsGeneric mps)) + pure $ + ConT ''Key + `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) + + -- TODO: if we keep mpsGeneric, this needs to check 'mpsGeneric' and then + -- append Generic to the model name, probably + _removeIdFromTypeSuffix :: Name -> Type + _removeIdFromTypeSuffix oldName@(Name (OccName nm) nameFlavor) = + case stripSuffix "Id" (T.pack nm) of + Nothing -> + ConT oldName + Just name -> + ConT ''Key + `AppT` do + ConT $ Name (OccName (T.unpack name)) nameFlavor + + -- | TODO: if we keep mpsGeneric, let's incorporate this behavior here, so + -- end users don't need to import the constructor type as well as the id type + -- + -- Returns 'Nothing' if the given text does not appear to be a table reference. + -- In that case, do the usual thing for generating a type name. + -- + -- Returns a @Just typ@ if the text appears to be a model name, and if the + -- @ModelId@ type is in scope. The 'Type' is a fully qualified reference to + -- @'Key' ModelName@ such that end users won't have to import it directly. + _lookupReferencedTable :: EntityMap -> Text -> Q (Maybe Type) + _lookupReferencedTable em fieldTypeText = do + let + mmodelIdString = do + fieldTypeNoId <- stripSuffix "Id" fieldTypeText + _ <- M.lookup (EntityNameHS fieldTypeNoId) em + pure (T.unpack fieldTypeText) + case mmodelIdString of + Nothing -> + pure Nothing + Just modelIdString -> do + mIdName <- lookupTypeName modelIdString + pure $ fmap _removeIdFromTypeSuffix mIdName + + _fieldNameEndsWithId :: UnboundFieldDef -> Maybe String + _fieldNameEndsWithId ufd = go (unboundFieldType ufd) + where + go = \case + FTTypeCon mmodule name -> do + a <- stripSuffix "Id" name + pure $ + T.unpack $ mconcat + [ case mmodule of + Nothing -> + "" + Just m -> + mconcat [m, "."] + , a + , "Id" + ] + _ -> + Nothing + +backendDataType :: MkPersistSettings -> Type +backendDataType mps + | mpsGeneric mps = backendT + | otherwise = mpsBackend mps + +-- | TODO: +-- +-- if we keep mpsGeneric +-- then +-- let's make this fully qualify the generic name +-- else +-- let's delete it +genericDataType + :: MkPersistSettings + -> EntityNameHS + -> Type -- ^ backend + -> Type +genericDataType mps name backend + | mpsGeneric mps = + ConT (mkEntityNameHSGenericName name) `AppT` backend + | otherwise = + ConT $ mkEntityNameHSName name + +degen :: [Clause] -> [Clause] +degen [] = + let err = VarE 'error `AppE` LitE (StringL + "Degenerate case, should never happen") + in [normalClause [WildP] err] +degen x = x + +-- needs: +-- +-- * isEntitySum ed +-- * field accesor +-- * getEntityFields ed +-- * used in goSum, or sumConstrName +-- * mkEntityDefName ed +-- * uses entityHaskell +-- * sumConstrName ed fieldDef +-- * only needs entity name and field name +-- +-- data MkToPersistFields = MkToPersistFields +-- { isEntitySum :: Bool +-- , entityHaskell :: HaskellNameHS +-- , entityFieldNames :: [FieldNameHS] +-- } +mkToPersistFields :: MkPersistSettings -> UnboundEntityDef -> Q Dec +mkToPersistFields mps ed = do + let isSum = unboundEntitySum ed + fields = getUnboundFieldDefs ed + clauses <- + if isSum + then sequence $ zipWith goSum fields [1..] + else fmap return go + return $ FunD 'toPersistFields clauses + where + go :: Q Clause + go = do + xs <- sequence $ replicate fieldCount $ newName "x" + let name = mkEntityDefName ed + pat = conp name $ fmap VarP xs + sp <- [|toPersistValue|] + let bod = ListE $ fmap (AppE sp . VarE) xs + return $ normalClause [pat] bod + + fieldCount = length (getUnboundFieldDefs ed) + + goSum :: UnboundFieldDef -> Int -> Q Clause + goSum fieldDef idx = do + let name = sumConstrName mps ed fieldDef + enull <- [|PersistNull|] + let beforeCount = idx - 1 + afterCount = fieldCount - idx + before = replicate beforeCount enull + after = replicate afterCount enull + x <- newName "x" + sp <- [|toPersistValue|] + let body = ListE $ mconcat + [ before + , [sp `AppE` VarE x] + , after + ] + return $ normalClause [conp name [VarP x]] body + +mkToFieldNames :: [UniqueDef] -> Q Dec +mkToFieldNames pairs = do + pairs' <- mapM go pairs + return $ FunD 'persistUniqueToFieldNames $ degen pairs' + where + go (UniqueDef constr _ names _) = do + names' <- lift names + return $ + normalClause + [RecP (mkConstraintName constr) []] + names' + +mkUniqueToValues :: [UniqueDef] -> Q Dec +mkUniqueToValues pairs = do + pairs' <- mapM go pairs + return $ FunD 'persistUniqueToValues $ degen pairs' + where + go :: UniqueDef -> Q Clause + go (UniqueDef constr _ names _) = do + xs <- mapM (const $ newName "x") names + let pat = conp (mkConstraintName constr) $ fmap VarP $ toList xs + tpv <- [|toPersistValue|] + let bod = ListE $ fmap (AppE tpv . VarE) $ toList xs + return $ normalClause [pat] bod + +isNotNull :: PersistValue -> Bool +isNotNull PersistNull = False +isNotNull _ = True + +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft _ (Right r) = Right r +mapLeft f (Left l) = Left (f l) + +-- needs: +-- +-- * getEntityFields +-- * sumConstrName on field +-- * fromValues +-- * entityHaskell +-- * sumConstrName +-- * entityDefConE +-- +-- +mkFromPersistValues :: MkPersistSettings -> UnboundEntityDef -> Q [Clause] +mkFromPersistValues mps entDef + | unboundEntitySum entDef = do + nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] + clauses <- mkClauses [] $ getUnboundFieldDefs entDef + return $ clauses `mappend` [normalClause [WildP] nothing] + | otherwise = + fromValues entDef "fromPersistValues" entE + $ fmap unboundFieldNameHS + $ filter isHaskellUnboundField + $ getUnboundFieldDefs entDef + where + entName = unEntityNameHS $ getUnboundEntityNameHS entDef + mkClauses _ [] = return [] + mkClauses before (field:after) = do + x <- newName "x" + let null' = conp 'PersistNull [] + pat = ListP $ mconcat + [ fmap (const null') before + , [VarP x] + , fmap (const null') after + ] + constr = ConE $ sumConstrName mps entDef field + fs <- [|fromPersistValue $(return $ VarE x)|] + let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x + let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] + clauses <- mkClauses (field : before) after + return $ clause : clauses + entE = entityDefConE entDef + + +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) + +fmapE :: Exp +fmapE = VarE 'fmap + +unboundEntitySum :: UnboundEntityDef -> Bool +unboundEntitySum = entitySum . unboundEntityDef + +fieldSel :: Name -> Name -> Exp +fieldSel conName fieldName + = LamE [RecP conName [(fieldName, VarP xName)]] (VarE xName) + where + xName = mkName "x" + +fieldUpd :: Name -- ^ constructor name + -> [Name] -- ^ list of field names + -> Exp -- ^ record value + -> Name -- ^ field name to update + -> Exp -- ^ new value + -> Q Exp +fieldUpd con names record name new = do + pats <- + fmap mconcat $ forM names $ \k -> do + varName <- VarP <$> newName (nameBase k) + pure [(k, varName) | k /= name] + + pure $ CaseE record + [ Match (RecP con pats) (NormalB body) []] + where + body = RecConE con + [ if k == name then (name, new) else (k, VarE k) + | k <- names + ] + +mkLensClauses :: MkPersistSettings -> UnboundEntityDef -> Type -> Q [Clause] +mkLensClauses mps entDef _genDataType = do + lens' <- [|lensPTH|] + getId <- [|entityKey|] + setId <- [|\(Entity _ value) key -> Entity key value|] + getVal <- [|entityVal|] + dot <- [|(.)|] + keyVar <- newName "key" + valName <- newName "value" + xName <- newName "x" + let idClause = normalClause + [conp (keyIdName entDef) []] + (lens' `AppE` getId `AppE` setId) + (idClause :) <$> if unboundEntitySum entDef + then pure $ fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef) + else zipWithM (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) fieldNames + where + fieldNames = fieldDefToRecordName mps entDef <$> getUnboundFieldDefs entDef + toClause lens' getVal dot keyVar valName xName fieldDef fieldName = do + setter <- mkSetter + pure $ normalClause + [conp (filterConName mps entDef fieldDef) []] + (lens' `AppE` getter `AppE` setter) + where + defName = mkEntityDefName entDef + getter = InfixE (Just $ fieldSel defName fieldName) dot (Just getVal) + mkSetter = do + updExpr <- fieldUpd defName fieldNames (VarE valName) fieldName (VarE xName) + pure $ LamE + [ conp 'Entity [VarP keyVar, VarP valName] + , VarP xName + ] + $ ConE 'Entity `AppE` VarE keyVar `AppE` updExpr + + toSumClause lens' keyVar valName xName fieldDef = normalClause + [conp (filterConName mps entDef fieldDef) []] + (lens' `AppE` getter `AppE` setter) + where + emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) [] + getter = LamE + [ conp 'Entity [WildP, VarP valName] + ] $ CaseE (VarE valName) + $ Match (conp (sumConstrName mps entDef fieldDef) [VarP xName]) (NormalB $ VarE xName) [] + + -- FIXME It would be nice if the types expressed that the Field is + -- a sum type and therefore could result in Maybe. + : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else [] + setter = LamE + [ conp 'Entity [VarP keyVar, WildP] + , VarP xName + ] + $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps entDef fieldDef) `AppE` VarE xName) + +-- | declare the key type and associated instances +-- @'PathPiece'@, @'ToHttpApiData'@ and @'FromHttpApiData'@ instances are only generated for a Key with one field +mkKeyTypeDec :: MkPersistSettings -> UnboundEntityDef -> Q (Dec, [Dec]) +mkKeyTypeDec mps entDef = do + (instDecs, i) <- + if mpsGeneric mps + then if not useNewtype + then do pfDec <- pfInstD + return (pfDec, supplement [''Generic]) + else do gi <- genericNewtypeInstances + return (gi, supplement []) + else if not useNewtype + then do pfDec <- pfInstD + return (pfDec, supplement [''Show, ''Read, ''Eq, ''Ord, ''Generic]) + else do + let allInstances = supplement [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''ToHttpApiData, ''FromHttpApiData, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON] + if customKeyType + then return ([], allInstances) + else do + bi <- backendKeyI + return (bi, allInstances) + + requirePersistentExtensions + + -- Always use StockStrategy for Show/Read. This means e.g. (FooKey 1) shows as ("FooKey 1"), rather than just "1" + -- This is much better for debugging/logging purposes + -- cf. https://github.com/yesodweb/persistent/issues/1104 + let alwaysStockStrategyTypeclasses = [''Show, ''Read] + deriveClauses = fmap (\typeclass -> + if (not useNewtype || typeclass `elem` alwaysStockStrategyTypeclasses) + then DerivClause (Just StockStrategy) [(ConT typeclass)] + else DerivClause (Just NewtypeStrategy) [(ConT typeclass)] + ) i + +#if MIN_VERSION_template_haskell(2,15,0) + let kd = if useNewtype + then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing dec deriveClauses + else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing [dec] deriveClauses +#else + let kd = if useNewtype + then NewtypeInstD [] k [recordType] Nothing dec deriveClauses + else DataInstD [] k [recordType] Nothing [dec] deriveClauses +#endif + return (kd, instDecs) + where + keyConE = keyConExp entDef + unKeyE = unKeyExp entDef + dec = RecC (keyConName entDef) (toList $ keyFields mps entDef) + k = ''Key + recordType = + genericDataType mps (getUnboundEntityNameHS entDef) backendT + pfInstD = -- FIXME: generate a PersistMap instead of PersistList + [d|instance PersistField (Key $(pure recordType)) where + toPersistValue = PersistList . keyToValues + fromPersistValue (PersistList l) = keyFromValues l + fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got + instance PersistFieldSql (Key $(pure recordType)) where + sqlType _ = SqlString + instance ToJSON (Key $(pure recordType)) + instance FromJSON (Key $(pure recordType)) + |] + + backendKeyGenericI = + [d| instance PersistStore $(pure backendT) => + ToBackendKey $(pure backendT) $(pure recordType) where + toBackendKey = $(return unKeyE) + fromBackendKey = $(return keyConE) + |] + backendKeyI = let bdt = backendDataType mps in + [d| instance ToBackendKey $(pure bdt) $(pure recordType) where + toBackendKey = $(return unKeyE) + fromBackendKey = $(return keyConE) + |] + + genericNewtypeInstances = do + requirePersistentExtensions + + alwaysInstances <- + -- See the "Always use StockStrategy" comment above, on why Show/Read use "stock" here + [d|deriving stock instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) + deriving stock instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) + deriving newtype instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) + deriving newtype instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) + deriving newtype instance ToHttpApiData (BackendKey $(pure backendT)) => ToHttpApiData (Key $(pure recordType)) + deriving newtype instance FromHttpApiData (BackendKey $(pure backendT)) => FromHttpApiData(Key $(pure recordType)) + deriving newtype instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) + deriving newtype instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) + deriving newtype instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) + deriving newtype instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) + deriving newtype instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) + |] + + mappend alwaysInstances <$> + if customKeyType + then pure [] + else backendKeyGenericI + + useNewtype = pkNewtype mps entDef + customKeyType = + or + [ not (defaultIdType entDef) + , not useNewtype + , isJust (entityPrimary (unboundEntityDef entDef)) + , not isBackendKey + ] + + isBackendKey = + case getImplicitIdType mps of + ConT bk `AppT` _ + | bk == ''BackendKey -> + True + _ -> + False + + supplement :: [Name] -> [Name] + supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) + +-- | Returns 'True' if the key definition has less than 2 fields. +-- +-- @since 2.11.0.0 +pkNewtype :: MkPersistSettings -> UnboundEntityDef -> Bool +pkNewtype mps entDef = length (keyFields mps entDef) < 2 + +-- | Kind of a nasty hack. Checks to see if the 'fieldType' matches what the +-- QuasiQuoter produces for an implicit ID and +defaultIdType :: UnboundEntityDef -> Bool +defaultIdType entDef = + case unboundPrimarySpec entDef of + DefaultKey _ -> + True + _ -> + False + +keyFields :: MkPersistSettings -> UnboundEntityDef -> NonEmpty (Name, Strict, Type) +keyFields mps entDef = + case unboundPrimarySpec entDef of + NaturalKey ucd -> + fmap naturalKeyVar (unboundCompositeCols ucd) + DefaultKey _ -> + pure . idKeyVar $ getImplicitIdType mps + SurrogateKey k -> + pure . idKeyVar $ case unboundIdType k of + Nothing -> + getImplicitIdType mps + Just ty -> + ftToType ty + where + unboundFieldDefs = + getUnboundFieldDefs entDef + naturalKeyVar fieldName = + case findField fieldName unboundFieldDefs of + Nothing -> + error "column not defined on entity" + Just unboundFieldDef -> + ( keyFieldName mps entDef (unboundFieldNameHS unboundFieldDef) + , notStrict + , ftToType $ unboundFieldType unboundFieldDef + ) + + idKeyVar ft = + ( unKeyName entDef + , notStrict + , ft + ) + +findField :: FieldNameHS -> [UnboundFieldDef] -> Maybe UnboundFieldDef +findField fieldName = + List.find ((fieldName ==) . unboundFieldNameHS) + +mkKeyToValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec +mkKeyToValues mps entDef = do + recordN <- newName "record" + FunD 'keyToValues . pure <$> + case unboundPrimarySpec entDef of + NaturalKey ucd -> do + normalClause [VarP recordN] <$> + toValuesPrimary recordN ucd + _ -> do + normalClause [] <$> + [|(:[]) . toPersistValue . $(pure $ unKeyExp entDef)|] + where + toValuesPrimary recName ucd = + ListE <$> mapM (f recName) (toList $ unboundCompositeCols ucd) + f recName fieldNameHS = + [| + toPersistValue ($(pure $ keyFieldSel fieldNameHS) $(varE recName)) + |] + keyFieldSel name + = fieldSel (keyConName entDef) (keyFieldName mps entDef name) + +normalClause :: [Pat] -> Exp -> Clause +normalClause p e = Clause p (NormalB e) [] + +-- needs: +-- +-- * entityPrimary +-- * keyConExp entDef +mkKeyFromValues :: MkPersistSettings -> UnboundEntityDef -> Q Dec +mkKeyFromValues _mps entDef = + FunD 'keyFromValues <$> + case unboundPrimarySpec entDef of + NaturalKey ucd -> + fromValues entDef "keyFromValues" keyConE (toList $ unboundCompositeCols ucd) + _ -> do + e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] + return [normalClause [] e] + where + keyConE = keyConExp entDef + +headNote :: [PersistValue] -> PersistValue +headNote = \case + [x] -> x + xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs + +-- needs from entity: +-- +-- * entityText entDef +-- * entityHaskell +-- * entityDB entDef +-- +-- needs from fields: +-- +-- * mkPersistValue +-- * fieldHaskell +-- +-- data MkFromValues = MkFromValues +-- { entityHaskell :: EntityNameHS +-- , entityDB :: EntitynameDB +-- , entityFieldNames :: [FieldNameHS] +-- } +fromValues :: UnboundEntityDef -> Text -> Exp -> [FieldNameHS] -> Q [Clause] +fromValues entDef funName constructExpr fields = do + x <- newName "x" + let + funMsg = + mconcat + [ entityText entDef + , ": " + , funName + , " failed on: " + ] + patternMatchFailure <- + [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] + suc <- patternSuccess + return [ suc, normalClause [VarP x] patternMatchFailure ] + where + tableName = + unEntityNameDB (entityDB (unboundEntityDef entDef)) + patternSuccess = + case fields of + [] -> do + rightE <- [|Right|] + return $ normalClause [ListP []] (rightE `AppE` constructExpr) + _ -> do + x1 <- newName "x1" + restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fields] + (fpv1:mkPersistValues) <- mapM mkPersistValue fields + app1E <- [|(<$>)|] + let conApp = infixFromPersistValue app1E fpv1 constructExpr x1 + applyE <- [|(<*>)|] + let applyFromPersistValue = infixFromPersistValue applyE + + return $ normalClause + [ListP $ fmap VarP (x1:restNames)] + (List.foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues)) + + infixFromPersistValue applyE fpv exp name = + UInfixE exp applyE (fpv `AppE` VarE name) + + mkPersistValue field = + let fieldName = unFieldNameHS field + in [|mapLeft (fieldError tableName fieldName) . fromPersistValue|] + +-- | Render an error message based on the @tableName@ and @fieldName@ with +-- the provided message. +-- +-- @since 2.8.2 +fieldError :: Text -> Text -> Text -> Text +fieldError tableName fieldName err = mconcat + [ "Couldn't parse field `" + , fieldName + , "` from table `" + , tableName + , "`. " + , err + ] + +mkEntity :: M.Map EntityNameHS a -> EntityMap -> MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkEntity embedEntityMap entityMap mps preDef = do + when (isEntitySum (unboundEntityDef preDef)) $ do + reportWarning $ unlines + [ "persistent has deprecated sum type entities as of 2.14.0.0." + , "We will delete support for these entities in 2.15.0.0." + , "If you need these, please add a comment on this GitHub issue:" + , "" + , " https://github.com/yesodweb/persistent/issues/987" + ] + + entityDefExp <- liftAndFixKeys mps embedEntityMap entityMap preDef + let + entDef = + fixEntityDef preDef + fields <- mkFields mps entityMap entDef + let name = mkEntityDefName entDef + let clazz = ConT ''PersistEntity `AppT` genDataType + tpf <- mkToPersistFields mps entDef + fpv <- mkFromPersistValues mps entDef + utv <- mkUniqueToValues $ entityUniques $ unboundEntityDef entDef + puk <- mkUniqueKeys entDef + fkc <- mapM (mkForeignKeysComposite mps entDef) $ unboundForeignDefs entDef + + toFieldNames <- mkToFieldNames $ entityUniques $ unboundEntityDef entDef + + (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps entDef + keyToValues' <- mkKeyToValues mps entDef + keyFromValues' <- mkKeyFromValues mps entDef + + let addSyn -- FIXME maybe remove this + | mpsGeneric mps = (:) $ + TySynD name [] $ + genericDataType mps entName $ mpsBackend mps + | otherwise = id + + lensClauses <- mkLensClauses mps entDef genDataType + + lenses <- mkLenses mps entityMap entDef + let instanceConstraint = if not (mpsGeneric mps) then [] else + [mkClassP ''PersistStore [backendT]] + + [keyFromRecordM'] <- + case unboundPrimarySpec entDef of + NaturalKey ucd -> do + let keyFields' = fieldNameToRecordName mps entDef <$> unboundCompositeCols ucd + keyFieldNames' <- forM keyFields' $ \fieldName -> do + fieldVarName <- newName (nameBase fieldName) + return (fieldName, fieldVarName) + + let keyCon = keyConName entDef + constr = + List.foldl' + AppE + (ConE keyCon) + (VarE . snd <$> keyFieldNames') + keyFromRec = varP 'keyFromRecordM + fieldPat = [(fieldName, VarP fieldVarName) | (fieldName, fieldVarName) <- toList keyFieldNames'] + lam = LamE [RecP name fieldPat ] constr + [d| + $(keyFromRec) = Just $(pure lam) + |] + + _ -> + [d|$(varP 'keyFromRecordM) = Nothing|] + + dtd <- dataTypeDec mps entityMap entDef + let + allEntDefs = + entityFieldTHCon <$> efthAllFields fields + allEntDefClauses = + entityFieldTHClause <$> efthAllFields fields + + mkTabulateA <- do + fromFieldName <- newName "fromField" + let names'types = + filter (\(n, _) -> n /= mkName "Id") $ map (getConNameAndType . entityFieldTHCon) $ entityFieldsTHFields fields + getConNameAndType = \case + ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC conName []) -> + (conName, fieldTy) + other -> + error $ mconcat + [ "persistent internal error: field constructor did not have xpected shape. \n" + , "Expected: \n" + , " ForallC [] [EqualityT `AppT` _ `AppT` fieldTy] (NormalC name [])\n" + , "Got: \n" + , " " <> show other + ] + mkEntityVal = + List.foldl' + (\acc (n, _) -> + InfixE + (Just acc) + (VarE '(<*>)) + (Just (VarE fromFieldName `AppE` ConE n)) + ) + (VarE 'pure `AppE` ConE (mkEntityNameHSName entName)) + names'types + primaryKeyField = + fst $ getConNameAndType $ entityFieldTHCon $ entityFieldsTHPrimary fields + body <- + if isEntitySum $ unboundEntityDef entDef + then [| error "tabulateEntityA does not make sense for sum type" |] + else + [| + Entity + <$> $(varE fromFieldName) $(conE primaryKeyField) + <*> $(pure mkEntityVal) + |] + + + pure $ + FunD 'tabulateEntityA + [ Clause [VarP fromFieldName] (NormalB body) [] + ] + + return $ addSyn $ + dtd : mconcat fkc `mappend` + ( [ TySynD (keyIdName entDef) [] $ + ConT ''Key `AppT` ConT name + , instanceD instanceConstraint clazz + [ uniqueTypeDec mps entityMap entDef + , keyTypeDec + , keyToValues' + , keyFromValues' + , keyFromRecordM' + , mkTabulateA + , FunD 'entityDef [normalClause [WildP] entityDefExp] + , tpf + , FunD 'fromPersistValues fpv + , toFieldNames + , utv + , puk +#if MIN_VERSION_template_haskell(2,15,0) + , DataInstD + [] + Nothing + (AppT (AppT (ConT ''EntityField) genDataType) (VarT $ mkName "typ")) + Nothing + allEntDefs + [] +#else + , DataInstD + [] + ''EntityField + [ genDataType + , VarT $ mkName "typ" + ] + Nothing + allEntDefs + [] +#endif + , FunD 'persistFieldDef allEntDefClauses +#if MIN_VERSION_template_haskell(2,15,0) + , TySynInstD + (TySynEqn + Nothing + (AppT (ConT ''PersistEntityBackend) genDataType) + (backendDataType mps)) +#else + , TySynInstD + ''PersistEntityBackend + (TySynEqn + [genDataType] + (backendDataType mps)) +#endif + , FunD 'persistIdField [normalClause [] (ConE $ keyIdName entDef)] + , FunD 'fieldLens lensClauses + ] + ] `mappend` lenses) `mappend` keyInstanceDecs + where + genDataType = + genericDataType mps entName backendT + entName = + getUnboundEntityNameHS preDef + +data EntityFieldsTH = EntityFieldsTH + { entityFieldsTHPrimary :: EntityFieldTH + , entityFieldsTHFields :: [EntityFieldTH] + } + +efthAllFields :: EntityFieldsTH -> [EntityFieldTH] +efthAllFields EntityFieldsTH{..} = + stripIdFieldDef entityFieldsTHPrimary : entityFieldsTHFields + +stripIdFieldDef :: EntityFieldTH -> EntityFieldTH +stripIdFieldDef efth = efth + { entityFieldTHClause = + go (entityFieldTHClause efth) + } + where + go (Clause ps bdy ds) = + Clause ps bdy' ds + where + bdy' = + case bdy of + NormalB e -> + NormalB $ AppE (VarE 'stripIdFieldImpl) e + _ -> + bdy + +-- | @persistent@ used to assume that an Id was always a single field. +-- +-- This method preserves as much backwards compatibility as possible. +stripIdFieldImpl :: HasCallStack => EntityIdDef -> FieldDef +stripIdFieldImpl eid = + case eid of + EntityIdField fd -> fd + EntityIdNaturalKey cd -> + case compositeFields cd of + (x :| xs) -> + case xs of + [] -> + x + _ -> + dummyFieldDef + where + dummyFieldDef = + FieldDef + { fieldHaskell = + FieldNameHS "Id" + , fieldDB = + FieldNameDB "__composite_key_no_id__" + , fieldType = + FTTypeCon Nothing "__Composite_Key__" + , fieldSqlType = + SqlOther "Composite Key" + , fieldAttrs = + [] + , fieldStrict = + False + , fieldReference = + NoReference + , fieldCascade = + noCascade + , fieldComments = + Nothing + , fieldGenerated = + Nothing + , fieldIsImplicitIdColumn = + False + } + +mkFields :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q EntityFieldsTH +mkFields mps entityMap entDef = + EntityFieldsTH + <$> mkIdField mps entDef + <*> mapM (mkField mps entityMap entDef) (getUnboundFieldDefs entDef) + +mkUniqueKeyInstances :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkUniqueKeyInstances mps entDef = do + requirePersistentExtensions + case entityUniques (unboundEntityDef entDef) of + [] -> mappend <$> typeErrorSingle <*> typeErrorAtLeastOne + [_] -> mappend <$> singleUniqueKey <*> atLeastOneKey + (_:_) -> mappend <$> typeErrorMultiple <*> atLeastOneKey + where + requireUniquesPName = 'requireUniquesP + onlyUniquePName = 'onlyUniqueP + typeErrorSingle = mkOnlyUniqueError typeErrorNoneCtx + typeErrorMultiple = mkOnlyUniqueError typeErrorMultipleCtx + + withPersistStoreWriteCxt = + if mpsGeneric mps + then do + write <- [t|PersistStoreWrite $(pure backendT) |] + pure [write] + else do + pure [] + + typeErrorNoneCtx = do + tyErr <- [t|TypeError (NoUniqueKeysError $(pure genDataType))|] + (tyErr :) <$> withPersistStoreWriteCxt + + typeErrorMultipleCtx = do + tyErr <- [t|TypeError (MultipleUniqueKeysError $(pure genDataType))|] + (tyErr :) <$> withPersistStoreWriteCxt + + mkOnlyUniqueError :: Q Cxt -> Q [Dec] + mkOnlyUniqueError mkCtx = do + ctx <- mkCtx + let impl = mkImpossible onlyUniquePName + pure [instanceD ctx onlyOneUniqueKeyClass impl] + + mkImpossible name = + [ FunD name + [ Clause + [ WildP ] + (NormalB + (VarE 'error `AppE` LitE (StringL "impossible")) + ) + [] + ] + ] + + typeErrorAtLeastOne :: Q [Dec] + typeErrorAtLeastOne = do + let impl = mkImpossible requireUniquesPName + cxt <- typeErrorNoneCtx + pure [instanceD cxt atLeastOneUniqueKeyClass impl] + + singleUniqueKey :: Q [Dec] + singleUniqueKey = do + expr <- [e| head . persistUniqueKeys|] + let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]] + cxt <- withPersistStoreWriteCxt + pure [instanceD cxt onlyOneUniqueKeyClass impl] + + atLeastOneUniqueKeyClass = ConT ''AtLeastOneUniqueKey `AppT` genDataType + onlyOneUniqueKeyClass = ConT ''OnlyOneUniqueKey `AppT` genDataType + + atLeastOneKey :: Q [Dec] + atLeastOneKey = do + expr <- [e| NEL.fromList . persistUniqueKeys|] + let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]] + cxt <- withPersistStoreWriteCxt + pure [instanceD cxt atLeastOneUniqueKeyClass impl] + + genDataType = + genericDataType mps (getUnboundEntityNameHS entDef) backendT + +entityText :: UnboundEntityDef -> Text +entityText = unEntityNameHS . getUnboundEntityNameHS + +mkLenses :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] +mkLenses mps _ _ | not (mpsGenerateLenses mps) = return [] +mkLenses _ _ ent | entitySum (unboundEntityDef ent) = return [] +mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` fieldNames) $ \(field, fieldName) -> do + let lensName = mkEntityLensName mps ent field + needleN <- newName "needle" + setterN <- newName "setter" + fN <- newName "f" + aN <- newName "a" + yN <- newName "y" + let needle = VarE needleN + setter = VarE setterN + f = VarE fN + a = VarE aN + y = VarE yN + fT = mkName "f" + -- FIXME if we want to get really fancy, then: if this field is the + -- *only* Id field present, then set backend1 and backend2 to different + -- values + backend1 = backendName + backend2 = backendName + aT = + maybeIdType mps entityMap field (Just backend1) Nothing + bT = + maybeIdType mps entityMap field (Just backend2) Nothing + mkST backend = + genericDataType mps (getUnboundEntityNameHS ent) (VarT backend) + sT = mkST backend1 + tT = mkST backend2 + t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 + vars = mkForallTV fT + : (if mpsGeneric mps then [mkForallTV backend1{-, PlainTV backend2-}] else []) + fieldUpdClause <- fieldUpd (mkEntityDefName ent) fieldNames a fieldName y + return + [ SigD lensName $ ForallT vars [mkClassP ''Functor [VarT fT]] $ + (aT `arrow` (VarT fT `AppT` bT)) `arrow` + (sT `arrow` (VarT fT `AppT` tT)) + , FunD lensName $ return $ Clause + [VarP fN, VarP aN] + (NormalB $ fmapE + `AppE` setter + `AppE` (f `AppE` needle)) + [ FunD needleN [normalClause [] (fieldSel (mkEntityDefName ent) fieldName `AppE` a)] + , FunD setterN $ return $ normalClause + [VarP yN] + fieldUpdClause + ] + ] + where + fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent + +#if MIN_VERSION_template_haskell(2,21,0) +mkPlainTV + :: Name + -> TyVarBndr BndrVis +mkPlainTV n = PlainTV n defaultBndrFlag + +mkForallTV :: Name -> TyVarBndr Specificity +mkForallTV n = PlainTV n SpecifiedSpec +#elif MIN_VERSION_template_haskell(2,17,0) +mkPlainTV + :: Name + -> TyVarBndr () +mkPlainTV n = PlainTV n () + +mkForallTV :: Name -> TyVarBndr Specificity +mkForallTV n = PlainTV n SpecifiedSpec +#else + +mkPlainTV + :: Name + -> TyVarBndr +mkPlainTV = PlainTV + +mkForallTV + :: Name + -> TyVarBndr +mkForallTV = mkPlainTV +#endif + +mkForeignKeysComposite + :: MkPersistSettings + -> UnboundEntityDef + -> UnboundForeignDef + -> Q [Dec] +mkForeignKeysComposite mps entDef foreignDef + | foreignToPrimary (unboundForeignDef foreignDef) = do + let + fieldName = + fieldNameToRecordName mps entDef + fname = + fieldName $ constraintToField $ foreignConstraintNameHaskell $ unboundForeignDef foreignDef + reftableString = + unpack $ unEntityNameHS $ foreignRefTableHaskell $ unboundForeignDef foreignDef + reftableKeyName = + mkName $ reftableString `mappend` "Key" + tablename = + mkEntityDefName entDef + fieldStore = + mkFieldStore entDef + + recordVarName <- newName "record_mkForeignKeysComposite" + + let + mkFldE foreignName = + -- using coerce here to convince SqlBackendKey to go away + VarE 'coerce `AppE` + (VarE (fieldName foreignName) `AppE` VarE recordVarName) + mkFldR ffr = + let + e = + mkFldE (ffrSourceField ffr) + in + case ffrTargetField ffr of + FieldNameHS "Id" -> + VarE 'toBackendKey `AppE` + e + _ -> + e + foreignFieldNames foreignFieldList = + case foreignFieldList of + FieldListImpliedId names -> + names + FieldListHasReferences refs -> + fmap ffrSourceField refs + + fldsE = + getForeignNames $ (unboundForeignFields foreignDef) + getForeignNames = \case + FieldListImpliedId xs -> + fmap mkFldE xs + FieldListHasReferences xs -> + fmap mkFldR xs + + nullErr n = + error $ "Could not find field definition for: " <> show n + fNullable = + setNull + $ fmap (\n -> fromMaybe (nullErr n) $ getFieldDef n fieldStore) + $ foreignFieldNames + $ unboundForeignFields foreignDef + mkKeyE = + List.foldl' AppE (maybeExp fNullable $ ConE reftableKeyName) fldsE + fn = + FunD fname [normalClause [VarP recordVarName] mkKeyE] + + keyTargetTable = + maybeTyp fNullable $ ConT ''Key `AppT` ConT (mkName reftableString) + + sigTy <- [t| $(conT tablename) -> $(pure keyTargetTable) |] + pure + [ SigD fname sigTy + , fn + ] + + | otherwise = + pure [] + where + constraintToField = FieldNameHS . unConstraintNameHS + + +maybeExp :: Bool -> Exp -> Exp +maybeExp may exp | may = fmapE `AppE` exp + | otherwise = exp + +maybeTyp :: Bool -> Type -> Type +maybeTyp may typ | may = ConT ''Maybe `AppT` typ + | otherwise = typ + +entityToPersistValueHelper :: (PersistEntity record) => record -> PersistValue +entityToPersistValueHelper entity = PersistMap $ zip columnNames fieldsAsPersistValues + where + columnNames = fmap (unFieldNameHS . fieldHaskell) (getEntityFields (entityDef (Just entity))) + fieldsAsPersistValues = fmap toPersistValue $ toPersistFields entity + +entityFromPersistValueHelper + :: (PersistEntity record) + => [String] -- ^ Column names, as '[String]' to avoid extra calls to "pack" in the generated code + -> PersistValue + -> Either Text record +entityFromPersistValueHelper columnNames pv = do + (persistMap :: [(T.Text, PersistValue)]) <- getPersistMap pv + + let columnMap = HM.fromList persistMap + lookupPersistValueByColumnName :: String -> PersistValue + lookupPersistValueByColumnName columnName = + fromMaybe PersistNull (HM.lookup (pack columnName) columnMap) + + fromPersistValues $ fmap lookupPersistValueByColumnName columnNames + +-- | Produce code similar to the following: +-- +-- @ +-- instance PersistEntity e => PersistField e where +-- toPersistValue = entityToPersistValueHelper +-- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] +-- sqlType _ = SqlString +-- @ +persistFieldFromEntity :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +persistFieldFromEntity mps entDef = do + sqlStringConstructor' <- [|SqlString|] + toPersistValueImplementation <- [|entityToPersistValueHelper|] + fromPersistValueImplementation <- [|entityFromPersistValueHelper columnNames|] + + return + [ persistFieldInstanceD (mpsGeneric mps) typ + [ FunD 'toPersistValue [ normalClause [] toPersistValueImplementation ] + , FunD 'fromPersistValue + [ normalClause [] fromPersistValueImplementation ] + ] + , persistFieldSqlInstanceD (mpsGeneric mps) typ + [ sqlTypeFunD sqlStringConstructor' + ] + ] + where + typ = + genericDataType mps (entityHaskell (unboundEntityDef entDef)) backendT + entFields = + filter isHaskellUnboundField $ getUnboundFieldDefs entDef + columnNames = + fmap (unpack . unFieldNameHS . unboundFieldNameHS) entFields + +-- | Apply the given list of functions to the same @EntityDef@s. +-- +-- This function is useful for cases such as: +-- +-- @ +-- share ['mkEntityDefList' "myDefs", 'mkPersist' sqlSettings] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- If you only have a single function, though, you don't need this. The +-- following is redundant: +-- +-- @ +-- 'share' ['mkPersist' 'sqlSettings'] ['persistLowerCase'| +-- -- ... +-- |] +-- @ +-- +-- Most functions require a full @['EntityDef']@, which can be provided +-- using @$('discoverEntities')@ for all entites in scope, or defining +-- 'mkEntityDefList' to define a list of entities from the given block. +share :: [[a] -> Q [Dec]] -> [a] -> Q [Dec] +share fs x = mconcat <$> mapM ($ x) fs + +-- | Creates a declaration for the @['EntityDef']@ from the @persistent@ +-- schema. This is necessary because the Persistent QuasiQuoter is unable +-- to know the correct type of ID fields, and assumes that they are all +-- Int64. +-- +-- Provide this in the list you give to 'share', much like @'mkMigrate'@. +-- +-- @ +-- 'share' ['mkMigrate' "migrateAll", 'mkEntityDefList' "entityDefs"] [...] +-- @ +-- +-- @since 2.7.1 +mkEntityDefList + :: String + -- ^ The name that will be given to the 'EntityDef' list. + -> [UnboundEntityDef] + -> Q [Dec] +mkEntityDefList entityList entityDefs = do + let entityListName = mkName entityList + edefs <- fmap ListE + . forM entityDefs + $ \entDef -> + let entityType = entityDefConT entDef + in [|entityDef (Proxy :: Proxy $(entityType))|] + typ <- [t|[EntityDef]|] + pure + [ SigD entityListName typ + , ValD (VarP entityListName) (NormalB edefs) [] + ] + +mkUniqueKeys :: UnboundEntityDef -> Q Dec +mkUniqueKeys def | entitySum (unboundEntityDef def) = + return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] +mkUniqueKeys def = do + c <- clause + return $ FunD 'persistUniqueKeys [c] + where + clause = do + xs <- forM (getUnboundFieldDefs def) $ \fieldDef -> do + let x = unboundFieldNameHS fieldDef + x' <- newName $ '_' : unpack (unFieldNameHS x) + return (x, x') + let pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def + let pat = conp + (mkEntityDefName def) + (fmap (VarP . snd) xs) + return $ normalClause [pat] (ListE pcs) + + go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp + go xs (UniqueDef name _ cols _) = + List.foldl' (go' xs) (ConE (mkConstraintName name)) (toList $ fmap fst cols) + + go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp + go' xs front col = + let col' = + fromMaybe (error $ "failed in go' while looking up col=" <> show col) (lookup col xs) + in front `AppE` VarE col' + +sqlTypeFunD :: Exp -> Dec +sqlTypeFunD st = FunD 'sqlType + [ normalClause [WildP] st ] + +typeInstanceD + :: Name + -> Bool -- ^ include PersistStore backend constraint + -> Type + -> [Dec] + -> Dec +typeInstanceD clazz hasBackend typ = + instanceD ctx (ConT clazz `AppT` typ) + where + ctx + | hasBackend = [mkClassP ''PersistStore [backendT]] + | otherwise = [] + +persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint + -> Type -> [Dec] -> Dec +persistFieldInstanceD = typeInstanceD ''PersistField + +persistFieldSqlInstanceD :: Bool -- ^ include PersistStore backend constraint + -> Type -> [Dec] -> Dec +persistFieldSqlInstanceD = typeInstanceD ''PersistFieldSql + +-- | Automatically creates a valid 'PersistField' instance for any datatype +-- that has valid 'Show' and 'Read' instances. Can be very convenient for +-- 'Enum' types. +derivePersistField :: String -> Q [Dec] +derivePersistField s = do + ss <- [|SqlString|] + tpv <- [|PersistText . pack . show|] + fpv <- [|\dt v -> + case fromPersistValue v of + Left e -> Left e + Right s' -> + case reads $ unpack s' of + (x, _):_ -> Right x + [] -> Left $ pack "Invalid " ++ pack dt ++ pack ": " ++ s'|] + return + [ persistFieldInstanceD False (ConT $ mkName s) + [ FunD 'toPersistValue + [ normalClause [] tpv + ] + , FunD 'fromPersistValue + [ normalClause [] (fpv `AppE` LitE (StringL s)) + ] + ] + , persistFieldSqlInstanceD False (ConT $ mkName s) + [ sqlTypeFunD ss + ] + ] + +-- | Automatically creates a valid 'PersistField' instance for any datatype +-- that has valid 'ToJSON' and 'FromJSON' instances. For a datatype @T@ it +-- generates instances similar to these: +-- +-- @ +-- instance PersistField T where +-- toPersistValue = PersistByteString . L.toStrict . encode +-- fromPersistValue = (left T.pack) . eitherDecodeStrict' <=< fromPersistValue +-- instance PersistFieldSql T where +-- sqlType _ = SqlString +-- @ +derivePersistFieldJSON :: String -> Q [Dec] +derivePersistFieldJSON s = do + ss <- [|SqlString|] + tpv <- [|PersistText . toJsonText|] + fpv <- [|\dt v -> do + text <- fromPersistValue v + let bs' = TE.encodeUtf8 text + case eitherDecodeStrict' bs' of + Left e -> Left $ pack "JSON decoding error for " ++ pack dt ++ pack ": " ++ pack e ++ pack ". On Input: " ++ decodeUtf8 bs' + Right x -> Right x|] + return + [ persistFieldInstanceD False (ConT $ mkName s) + [ FunD 'toPersistValue + [ normalClause [] tpv + ] + , FunD 'fromPersistValue + [ normalClause [] (fpv `AppE` LitE (StringL s)) + ] + ] + , persistFieldSqlInstanceD False (ConT $ mkName s) + [ sqlTypeFunD ss + ] + ] + +-- | The basic function for migrating models, no Template Haskell required. +-- +-- It's probably best to use this in concert with 'mkEntityDefList', and then +-- call 'migrateModels' with the result from that function. +-- +-- @ +-- share [mkPersist sqlSettings, mkEntityDefList "entities"] [persistLowerCase| ... |] +-- +-- migrateAll = 'migrateModels' entities +-- @ +-- +-- The function 'mkMigrate' currently implements exactly this behavior now. If +-- you're splitting up the entity definitions into separate files, then it is +-- better to use the entity definition list and the concatenate all the models +-- together into a big list to call with 'migrateModels'. +-- +-- @ +-- module Foo where +-- +-- share [mkPersist s, mkEntityDefList "fooModels"] ... +-- +-- +-- module Bar where +-- +-- share [mkPersist s, mkEntityDefList "barModels"] ... +-- +-- module Migration where +-- +-- import Foo +-- import Bar +-- +-- migrateAll = migrateModels (fooModels <> barModels) +-- @ +-- +-- @since 2.13.0.0 +migrateModels :: [EntityDef] -> Migration +migrateModels defs= + forM_ (filter isMigrated defs) $ \def -> + migrate defs def + where + isMigrated def = pack "no-migrate" `notElem` entityAttrs def + +-- | Creates a single function to perform all migrations for the entities +-- defined here. One thing to be aware of is dependencies: if you have entities +-- with foreign references, make sure to place those definitions after the +-- entities they reference. +-- +-- In @persistent-2.13.0.0@, this was changed to *ignore* the input entity def +-- list, and instead defer to 'mkEntityDefList' to get the correct entities. +-- This avoids problems where the QuasiQuoter is unable to know what the right +-- reference types are. This sets 'mkPersist' to be the "single source of truth" +-- for entity definitions. +mkMigrate :: String -> [UnboundEntityDef] -> Q [Dec] +mkMigrate fun eds = do + let entityDefListName = ("entityDefListFor" <> fun) + body <- [| migrateModels $(varE (mkName entityDefListName)) |] + edList <- mkEntityDefList entityDefListName eds + pure $ edList <> + [ SigD (mkName fun) (ConT ''Migration) + , FunD (mkName fun) [normalClause [] body] + ] + +data EntityFieldTH = EntityFieldTH + { entityFieldTHCon :: Con + , entityFieldTHClause :: Clause + } + +-- Ent +-- fieldName FieldType +-- +-- forall . typ ~ FieldType => EntFieldName +-- +-- EntFieldName = FieldDef .... +-- +-- Field Def Accessors Required: +mkField :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> UnboundFieldDef -> Q EntityFieldTH +mkField mps entityMap et fieldDef = do + let + con = + ForallC + [] + [mkEqualP (VarT $ mkName "typ") fieldT] + $ NormalC name [] + fieldT = + maybeIdType mps entityMap fieldDef Nothing Nothing + bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef) + let cla = normalClause + [conp name []] + bod + return $ EntityFieldTH con cla + where + name = filterConName mps et fieldDef + +mkIdField :: MkPersistSettings -> UnboundEntityDef -> Q EntityFieldTH +mkIdField mps ued = do + let + entityName = + getUnboundEntityNameHS ued + entityIdType + | mpsGeneric mps = + ConT ''Key `AppT` ( + ConT (mkEntityNameHSGenericName entityName) + `AppT` backendT + ) + | otherwise = + ConT $ mkName $ (T.unpack $ unEntityNameHS entityName) ++ "Id" + name = + filterConName' mps entityName (FieldNameHS "Id") + clause <- + fixPrimarySpec mps ued + pure EntityFieldTH + { entityFieldTHCon = + ForallC + [] + [mkEqualP (VarT $ mkName "typ") entityIdType] + $ NormalC name [] + , entityFieldTHClause = + normalClause [conp name []] clause + } + +lookupEntityField + :: PersistEntity entity + => Proxy entity + -> FieldNameHS + -> FieldDef +lookupEntityField prxy fieldNameHS = + fromMaybe boom $ List.find ((fieldNameHS ==) . fieldHaskell) $ entityFields $ entityDef prxy + where + boom = + error "Database.Persist.TH.Internal.lookupEntityField: failed to find entity field with database name" + +mkLookupEntityField + :: UnboundEntityDef + -> FieldNameHS + -> Q Exp +mkLookupEntityField ued ufd = + [| + lookupEntityField + (Proxy :: Proxy $(conT entityName)) + $(lift ufd) + |] + where + entityName = mkEntityNameHSName (getUnboundEntityNameHS ued) + +maybeNullable :: UnboundFieldDef -> Bool +maybeNullable fd = isUnboundFieldNullable fd == Nullable ByMaybeAttr + +ftToType :: FieldType -> Type +ftToType = \case + FTTypeCon Nothing t -> + ConT $ mkName $ T.unpack t + -- This type is generated from the Quasi-Quoter. + -- Adding this special case avoids users needing to import Data.Int + FTTypeCon (Just "Data.Int") "Int64" -> + ConT ''Int64 + FTTypeCon (Just m) t -> + ConT $ mkName $ unpack $ concat [m, ".", t] + FTLit l -> + LitT (typeLitToTyLit l) + FTTypePromoted t -> + PromotedT $ mkName $ T.unpack t + FTApp x y -> + ftToType x `AppT` ftToType y + FTList x -> + ListT `AppT` ftToType x + +typeLitToTyLit :: FieldTypeLit -> TyLit +typeLitToTyLit = \case + IntTypeLit n -> NumTyLit n + TextTypeLit t -> StrTyLit (T.unpack t) + +infixr 5 ++ +(++) :: Monoid m => m -> m -> m +(++) = mappend + +mkJSON :: MkPersistSettings -> UnboundEntityDef -> Q [Dec] +mkJSON _ def | ("json" `notElem` entityAttrs (unboundEntityDef def)) = return [] +mkJSON mps (fixEntityDef -> def) = do + requireExtensions [[FlexibleInstances]] + pureE <- [|pure|] + apE' <- [|(<*>)|] + + let objectE = VarE 'object + withObjectE = VarE 'withObject + dotEqualE = VarE '(.=) + dotColonE = VarE '(.:) + dotColonQE = VarE '(.:?) +#if MIN_VERSION_aeson(2,0,0) + toKeyE = VarE 'Key.fromString +#else + toKeyE = VarE 'pack +#endif + obj <- newName "obj" + let + fields = + getUnboundFieldDefs def + + xs <- mapM fieldToJSONValName fields + + let + conName = + mkEntityDefName def + typ = + genericDataType mps (entityHaskell (unboundEntityDef def)) backendT + toJSONI = + typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] + where + toJSON' = FunD 'toJSON $ return $ normalClause + [conp conName $ fmap VarP xs] + (objectE `AppE` ListE pairs) + where + pairs = zipWith toPair fields xs + toPair f x = InfixE + (Just (toKeyE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f))) + dotEqualE + (Just $ VarE x) + fromJSONI = + typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] + where + entNameStrLit = + StringL $ T.unpack (unEntityNameHS (getUnboundEntityNameHS def)) + parseJSONBody = + withObjectE `AppE` LitE entNameStrLit `AppE` decoderImpl + parseJSON' = + FunD 'parseJSON [ normalClause [] parseJSONBody ] + decoderImpl = + LamE [VarP obj] + (List.foldl' + (\x y -> InfixE (Just x) apE' (Just y)) + (pureE `AppE` ConE conName) + pulls + ) + where + pulls = + fmap toPull fields + toPull f = InfixE + (Just $ VarE obj) + (if maybeNullable f then dotColonQE else dotColonE) + (Just $ AppE toKeyE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f) + + case mpsEntityJSON mps of + Nothing -> + return [toJSONI, fromJSONI] + Just entityJSON -> do + entityJSONIs <- if mpsGeneric mps + then [d| + instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where + toJSON = $(varE (entityToJSON entityJSON)) + instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where + parseJSON = $(varE (entityFromJSON entityJSON)) + |] + else [d| + instance ToJSON (Entity $(pure typ)) where + toJSON = $(varE (entityToJSON entityJSON)) + instance FromJSON (Entity $(pure typ)) where + parseJSON = $(varE (entityFromJSON entityJSON)) + |] + return $ toJSONI : fromJSONI : entityJSONIs + +mkClassP :: Name -> [Type] -> Pred +mkClassP cla tys = List.foldl AppT (ConT cla) tys + +mkEqualP :: Type -> Type -> Pred +mkEqualP tleft tright = List.foldl AppT EqualityT [tleft, tright] + +notStrict :: Bang +notStrict = Bang NoSourceUnpackedness NoSourceStrictness + +isStrict :: Bang +isStrict = Bang NoSourceUnpackedness SourceStrict + +instanceD :: Cxt -> Type -> [Dec] -> Dec +instanceD = InstanceD Nothing + +-- | Check that all of Persistent's required extensions are enabled, or else fail compilation +-- +-- This function should be called before any code that depends on one of the required extensions being enabled. +requirePersistentExtensions :: Q () +requirePersistentExtensions = requireExtensions requiredExtensions + where + requiredExtensions = fmap pure + [ DerivingStrategies + , GeneralizedNewtypeDeriving + , StandaloneDeriving + , UndecidableInstances + , MultiParamTypeClasses + ] + +mkSymbolToFieldInstances :: MkPersistSettings -> EntityMap -> UnboundEntityDef -> Q [Dec] +mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do + let + entityHaskellName = + getEntityHaskellName $ unboundEntityDef ed + allFields = + getUnboundFieldDefs ed + mkEntityFieldConstr fieldHaskellName = + conE $ filterConName' mps entityHaskellName fieldHaskellName + :: Q Exp + regularFields <- forM (toList allFields) $ \fieldDef -> do + let + fieldHaskellName = + unboundFieldNameHS fieldDef + + let fieldNameT :: Q Type + fieldNameT = + litT $ strTyLit + $ T.unpack $ lowerFirstIfId + $ unFieldNameHS fieldHaskellName + + lowerFirstIfId "Id" = "id" + lowerFirstIfId xs = xs + + fieldTypeT + | fieldHaskellName == FieldNameHS "Id" = + conT ''Key `appT` recordNameT + | otherwise = + pure $ maybeIdType mps entityMap fieldDef Nothing Nothing + entityFieldConstr = + mkEntityFieldConstr fieldHaskellName + mkInstance fieldNameT fieldTypeT entityFieldConstr + + mkey <- do + let + fieldHaskellName = + FieldNameHS "Id" + entityFieldConstr = + mkEntityFieldConstr fieldHaskellName + fieldTypeT = + conT ''Key `appT` recordNameT + mkInstance [t|"id"|] fieldTypeT entityFieldConstr + + pure (mkey <> join regularFields) + where + nameG = + mkEntityDefGenericName ed + recordNameT + | mpsGeneric mps = + conT nameG `appT` varT backendName + | otherwise = + entityDefConT ed + mkInstance fieldNameT fieldTypeT entityFieldConstr = + [d| + instance SymbolToField $(fieldNameT) $(recordNameT) $(fieldTypeT) where + symbolToField = $(entityFieldConstr) + |] + +-- | Pass in a list of lists of extensions, where any of the given +-- extensions will satisfy it. For example, you might need either GADTs or +-- ExistentialQuantification, so you'd write: +-- +-- > requireExtensions [[GADTs, ExistentialQuantification]] +-- +-- But if you need TypeFamilies and MultiParamTypeClasses, then you'd +-- write: +-- +-- > requireExtensions [[TypeFamilies], [MultiParamTypeClasses]] +requireExtensions :: [[Extension]] -> Q () +requireExtensions requiredExtensions = do + -- isExtEnabled breaks the persistent-template benchmark with the following error: + -- Template Haskell error: Can't do `isExtEnabled' in the IO monad + -- You can workaround this by replacing isExtEnabled with (pure . const True) + unenabledExtensions <- filterM (fmap (not . or) . traverse isExtEnabled) requiredExtensions + + case mapMaybe listToMaybe unenabledExtensions of + [] -> pure () + [extension] -> fail $ mconcat + [ "Generating Persistent entities now requires the " + , show extension + , " language extension. Please enable it by copy/pasting this line to the top of your file:\n\n" + , extensionToPragma extension + ] + extensions -> fail $ mconcat + [ "Generating Persistent entities now requires the following language extensions:\n\n" + , List.intercalate "\n" (fmap show extensions) + , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" + , List.intercalate "\n" (fmap extensionToPragma extensions) + ] + + where + extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" + +-- | creates a TH Name for use in the ToJSON instance +fieldToJSONValName :: UnboundFieldDef -> Q Name +fieldToJSONValName = + newName . T.unpack . unFieldNameHSForJSON . unboundFieldNameHS + +-- | This special-cases "type_" and strips out its underscore. When +-- used for JSON serialization and deserialization, it works around +-- +unFieldNameHSForJSON :: FieldNameHS -> Text +unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS + where + fixTypeUnderscore = \case + "type" -> "type_" + name -> name + +entityDefConK :: UnboundEntityDef -> Kind +entityDefConK = conK . mkEntityDefName + +entityDefConT :: UnboundEntityDef -> Q Type +entityDefConT = pure . entityDefConK + +entityDefConE :: UnboundEntityDef -> Exp +entityDefConE = ConE . mkEntityDefName + +-- | creates a TH Name for an entity's field, based on the entity +-- name and the field name, so for example: +-- +-- Customer +-- name Text +-- +-- This would generate `customerName` as a TH Name +fieldNameToRecordName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name +fieldNameToRecordName mps entDef fieldName = + mkRecordName mps mUnderscore (entityHaskell (unboundEntityDef entDef)) fieldName + where + mUnderscore + | mpsGenerateLenses mps = Just "_" + | otherwise = Nothing + +-- | as above, only takes a `FieldDef` +fieldDefToRecordName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name +fieldDefToRecordName mps entDef fieldDef = + fieldNameToRecordName mps entDef (unboundFieldNameHS fieldDef) + +-- | creates a TH Name for a lens on an entity's field, based on the entity +-- name and the field name, so as above but for the Lens +-- +-- Customer +-- name Text +-- +-- Generates a lens `customerName` when `mpsGenerateLenses` is true +-- while `fieldNameToRecordName` generates a prefixed function +-- `_customerName` +mkEntityLensName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name +mkEntityLensName mps entDef fieldDef = + mkRecordName mps Nothing (entityHaskell (unboundEntityDef entDef)) (unboundFieldNameHS fieldDef) + +mkRecordName :: MkPersistSettings -> Maybe Text -> EntityNameHS -> FieldNameHS -> Name +mkRecordName mps prefix entNameHS fieldNameHS = + mkName $ T.unpack . avoidKeyword $ fromMaybe "" prefix <> lowerFirst recName + where + recName :: Text + recName + | mpsPrefixFields mps = mpsFieldLabelModifier mps entityNameText (upperFirst fieldNameText) + | otherwise = fieldNameText + + entityNameText :: Text + entityNameText = + unEntityNameHS entNameHS + + fieldNameText :: Text + fieldNameText = + unFieldNameHS fieldNameHS + + avoidKeyword :: Text -> Text + avoidKeyword name = if name `Set.member` haskellKeywords then mpsAvoidHsKeyword mps name else name + +haskellKeywords :: Set.Set Text +haskellKeywords = Set.fromList + ["case","class","data","default","deriving","do","else" + ,"if","import","in","infix","infixl","infixr","instance","let","module" + ,"newtype","of","then","type","where","_" + ,"foreign" + ] + +-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` +mkEntityDefDeriveNames :: MkPersistSettings -> UnboundEntityDef -> [Name] +mkEntityDefDeriveNames mps entDef = + let + entityInstances = + mkName . T.unpack <$> entityDerives (unboundEntityDef entDef) + additionalInstances = + filter (`notElem` entityInstances) $ mpsDeriveInstances mps + in + entityInstances <> additionalInstances + +-- | Make a TH Name for the EntityDef's Haskell type +mkEntityNameHSName :: EntityNameHS -> Name +mkEntityNameHSName = + mkName . T.unpack . unEntityNameHS + +-- | As above only taking an `EntityDef` +mkEntityDefName :: UnboundEntityDef -> Name +mkEntityDefName = + mkEntityNameHSName . entityHaskell . unboundEntityDef + +-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric +mkEntityDefGenericName :: UnboundEntityDef -> Name +mkEntityDefGenericName = + mkEntityNameHSGenericName . entityHaskell . unboundEntityDef + +mkEntityNameHSGenericName :: EntityNameHS -> Name +mkEntityNameHSGenericName name = + mkName $ T.unpack (unEntityNameHS name <> "Generic") + +-- needs: +-- +-- * entityHaskell +-- * field on EntityDef +-- * fieldHaskell +-- * field on FieldDef +-- +sumConstrName :: MkPersistSettings -> UnboundEntityDef -> UnboundFieldDef -> Name +sumConstrName mps entDef unboundFieldDef = + mkName $ T.unpack name + where + name + | mpsPrefixFields mps = modifiedName ++ "Sum" + | otherwise = fieldName ++ "Sum" + fieldNameHS = + unboundFieldNameHS unboundFieldDef + modifiedName = + mpsConstraintLabelModifier mps entityName fieldName + entityName = + unEntityNameHS $ getUnboundEntityNameHS entDef + fieldName = + upperFirst $ unFieldNameHS fieldNameHS + +-- | Turn a ConstraintName into a TH Name +mkConstraintName :: ConstraintNameHS -> Name +mkConstraintName (ConstraintNameHS name) = + mkName (T.unpack name) + +keyIdName :: UnboundEntityDef -> Name +keyIdName = mkName . T.unpack . keyIdText + +keyIdText :: UnboundEntityDef -> Text +keyIdText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) `mappend` "Id" + +unKeyName :: UnboundEntityDef -> Name +unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef + +unKeyExp :: UnboundEntityDef -> Exp +unKeyExp ent = fieldSel (keyConName ent) (unKeyName ent) + +backendT :: Type +backendT = VarT backendName + +backendName :: Name +backendName = mkName "backend" + +-- needs: +-- +-- * keyText +-- * entityNameHaskell +-- * fields +-- * fieldHaskell +-- +-- keyConName :: EntityNameHS -> [FieldHaskell] -> Name +keyConName :: UnboundEntityDef -> Name +keyConName entDef = + keyConName' + (getUnboundEntityNameHS entDef) + (unboundFieldNameHS <$> unboundEntityFields (entDef)) + + +keyConName' :: EntityNameHS -> [FieldNameHS] -> Name +keyConName' entName entFields = mkName $ T.unpack $ resolveConflict $ keyText' entName + where + resolveConflict kn = if conflict then kn `mappend` "'" else kn + conflict = any (== FieldNameHS "key") entFields + +-- keyConExp :: EntityNameHS -> [FieldNameHS] -> Exp +keyConExp :: UnboundEntityDef -> Exp +keyConExp ed = ConE $ keyConName ed + +keyText :: UnboundEntityDef -> Text +keyText entDef = unEntityNameHS (getUnboundEntityNameHS entDef) ++ "Key" + +keyText' :: EntityNameHS -> Text +keyText' entName = unEntityNameHS entName ++ "Key" + +keyFieldName :: MkPersistSettings -> UnboundEntityDef -> FieldNameHS -> Name +keyFieldName mps entDef fieldDef + | pkNewtype mps entDef = + unKeyName entDef + | otherwise = + mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` fieldName + where + fieldName = modifyFieldName (unFieldNameHS fieldDef) + modifyFieldName = + if mpsCamelCaseCompositeKeySelector mps then upperFirst else id + +filterConName + :: MkPersistSettings + -> UnboundEntityDef + -> UnboundFieldDef + -> Name +filterConName mps (unboundEntityDef -> entity) field = + filterConName' mps (entityHaskell entity) (unboundFieldNameHS field) + +filterConName' + :: MkPersistSettings + -> EntityNameHS + -> FieldNameHS + -> Name +filterConName' mps entity field = mkName $ T.unpack name + where + name + | field == FieldNameHS "Id" = entityName ++ fieldName + | mpsPrefixFields mps = modifiedName + | otherwise = fieldName + + modifiedName = mpsConstraintLabelModifier mps entityName fieldName + entityName = unEntityNameHS entity + fieldName = upperFirst $ unFieldNameHS field + +{-| +Splice in a list of all 'EntityDef' in scope. This is useful when running +'mkPersist' to ensure that all entity definitions are available for setting +foreign keys, and for performing migrations with all entities available. + +'mkPersist' has the type @MkPersistSettings -> [EntityDef] -> DecsQ@. So, to +account for entities defined elsewhere, you'll @mappend $(discoverEntities)@. + +For example, + +@ +share + [ mkPersistWith sqlSettings $(discoverEntities) + ] + [persistLowerCase| ... |] +@ + +Likewise, to run migrations with all entity instances in scope, you'd write: + +@ +migrateAll = migrateModels $(discoverEntities) +@ + +Note that there is some odd behavior with Template Haskell and splicing +groups. If you call 'discoverEntities' in the same module that defines +'PersistEntity' instances, you need to ensure they are in different top-level +binding groups. You can write @$(pure [])@ at the top level to do this. + +@ +-- Foo and Bar both export an instance of PersistEntity +import Foo +import Bar + +-- Since Foo and Bar are both imported, discoverEntities can find them here. +mkPersistWith sqlSettings $(discoverEntities) [persistLowerCase| + User + name Text + age Int + |] + +-- onlyFooBar is defined in the same 'top level group' as the above generated +-- instance for User, so it isn't present in this list. +onlyFooBar :: [EntityDef] +onlyFooBar = $(discoverEntities) + +-- We can manually create a new binding group with this, which splices an +-- empty list of declarations in. +$(pure []) + +-- fooBarUser is able to see the 'User' instance. +fooBarUser :: [EntityDef] +fooBarUser = $(discoverEntities) +@ + +@since 2.13.0.0 +-} +discoverEntities :: Q Exp +discoverEntities = do + instances <- reifyInstances ''PersistEntity [VarT (mkName "a")] + let + types = + mapMaybe getDecType instances + getDecType dec = + case dec of + InstanceD _moverlap [] typ _decs -> + stripPersistEntity typ + _ -> + Nothing + stripPersistEntity typ = + case typ of + AppT (ConT tyName) t | tyName == ''PersistEntity -> + Just t + _ -> + Nothing + + fmap ListE $ + forM types $ \typ -> do + [e| entityDef (Proxy :: Proxy $(pure typ)) |] + +setNull :: NonEmpty UnboundFieldDef -> Bool +setNull (fd :| fds) = + let + nullSetting = + isNull fd + isNull = + (NotNullable /=) . isUnboundFieldNullable + in + if all ((nullSetting ==) . isNull) fds + then nullSetting + else error $ + "foreign key columns must all be nullable or non-nullable" + ++ show (fmap (unFieldNameHS . unboundFieldNameHS) (fd:fds)) diff --git a/Database/Persist/Types.hs b/Database/Persist/Types.hs --- a/Database/Persist/Types.hs +++ b/Database/Persist/Types.hs @@ -69,6 +69,7 @@ , PersistValue(..) , ReferenceDef(..) , SqlType(..) + , Span(..) , UniqueDef(..) , UpdateException(..) , WhyNullable(..) diff --git a/Database/Persist/Types/Base.hs b/Database/Persist/Types/Base.hs --- a/Database/Persist/Types/Base.hs +++ b/Database/Persist/Types/Base.hs @@ -13,6 +13,7 @@ , PersistValue(..) , fromPersistValueText , LiteralType(..) + , Span(..) ) where import Control.Exception (Exception) @@ -38,6 +39,7 @@ import Database.Persist.Names import Database.Persist.PersistValue +import Database.Persist.Types.Span (Span(..)) -- | A 'Checkmark' should be used as a field type whenever a -- uniqueness constraint should guarantee that a certain kind of @@ -155,6 +157,14 @@ -- ^ Optional comments on the entity. -- -- @since 2.10.0 + , entitySpan :: !(Maybe Span) + -- ^ Source code span occupied by this entity. May be absent if it is not + -- known. + -- + -- Note that until a refactor is completed, these cover the entire + -- persistent parser input rather than the particular entity in question. + -- + -- @since 2.15.0.0 } deriving (Show, Eq, Read, Ord, Lift) diff --git a/Database/Persist/Types/Span.hs b/Database/Persist/Types/Span.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Types/Span.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveLift #-} + +module Database.Persist.Types.Span (Span (..)) where + +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) + +-- | A pair of (start line/col, end line/col) coordinates. The end column will +-- be one past the final character (i.e. the span (1,1)->(1,1) is zero +-- characters long). +-- +-- Spans are 1-indexed in both lines and columns. +-- +-- Conceptually identical to GHC's @RealSourceSpan@. +-- +-- @since 2.15.0.0 +data Span = Span + { spanFile :: !Text + , spanStartLine :: !Int + , spanStartCol :: !Int + , spanEndLine :: !Int + , spanEndCol :: !Int + } + deriving (Show, Eq, Read, Ord, Lift) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -14,6 +14,7 @@ import Database.Persist.Quasi import Database.Persist.TH +import Database.Persist.TH.Internal import Models main :: IO () diff --git a/bench/Models.hs b/bench/Models.hs --- a/bench/Models.hs +++ b/bench/Models.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} module Models where import Data.Monoid @@ -7,6 +8,7 @@ import Database.Persist.Quasi import Database.Persist.Quasi.Internal import Database.Persist.TH +import Database.Persist.TH.Internal import Database.Persist.Sql -- TODO: we use lookupName and reify etc which breaks in IO. somehow need to @@ -18,7 +20,7 @@ parseReferences' = runQ . parseReferencesQ parseReferencesQ :: String -> Q Exp -parseReferencesQ = parseReferences lowerCaseSettings . Text.pack +parseReferencesQ = parseReferences lowerCaseSettings . pure . (Nothing,) . Text.pack -- | # of models, # of fields mkModels :: Int -> Int -> String diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.6.3 +version: 2.15.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -65,6 +65,7 @@ Database.Persist.ImplicitIdDef Database.Persist.ImplicitIdDef.Internal Database.Persist.TH + Database.Persist.TH.Internal Database.Persist.Quasi Database.Persist.Quasi.Internal @@ -95,6 +96,7 @@ other-modules: Database.Persist.Types.Base + Database.Persist.Types.Span Database.Persist.Sql.Internal Database.Persist.Sql.Types @@ -157,7 +159,9 @@ hs-source-dirs: test/ - ghc-options: -Wall + -- don't warn on partial matches, they're all over the place in the + -- testsuite and if they crash they will just fail the test. + ghc-options: -Wall -Wno-incomplete-uni-patterns default-extensions: FlexibleContexts , MultiParamTypeClasses @@ -202,7 +206,7 @@ source-repository head type: git - location: git://github.com/yesodweb/persistent.git + location: https://github.com/yesodweb/persistent.git benchmark persistent-th-bench ghc-options: -O2 diff --git a/test/Database/Persist/QuasiSpec.hs b/test/Database/Persist/QuasiSpec.hs --- a/test/Database/Persist/QuasiSpec.hs +++ b/test/Database/Persist/QuasiSpec.hs @@ -8,7 +8,6 @@ import Prelude hiding (lines) import Control.Exception -import Control.Monad import Data.List hiding (lines) import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL @@ -23,6 +22,13 @@ import Test.QuickCheck import Text.Shakespeare.Text (st) +defs :: T.Text -> [UnboundEntityDef] +defs t = parse lowerCaseSettings [(Nothing, t)] + +defsSnake :: T.Text -> [UnboundEntityDef] +defsSnake t = parse (setPsUseSnakeCaseForeignKeys lowerCaseSettings) [(Nothing, t)] + + spec :: Spec spec = describe "Quasi" $ do describe "parseEntityFields" $ do @@ -270,7 +276,7 @@ car CarId -- | the car reference |] - let [bicycle, car, vehicle] = parse lowerCaseSettings subject + let [bicycle, car, vehicle] = defs subject it "should parse the `entityHaskell` field" $ do getUnboundEntityNameHS bicycle `shouldBe` EntityNameHS "Bicycle" @@ -312,7 +318,7 @@ (simplifyUnique <$> entityUniques (unboundEntityDef vehicle)) `shouldBe` [] it "should parse the `entityForeigns` field" $ do - let [user, notification] = parse lowerCaseSettings [st| + let [user, notification] = defs [st| User name Text emailFirst Text @@ -371,7 +377,7 @@ name Text age (Maybe Int |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions evaluate (unboundEntityDef user) `shouldErrorWithMessage` "Unterminated parens string starting with Maybe Int" @@ -381,7 +387,7 @@ User age Int OnUpdateCascade OnUpdateCascade |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) `shouldErrorWithMessage` "found more than one OnUpdate action, tokens: [\"OnUpdateCascade\",\"OnUpdateCascade\"]" @@ -391,7 +397,7 @@ User age Int OnDeleteCascade OnDeleteCascade |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions mapM (evaluate . unboundFieldCascade) (unboundEntityFields user) `shouldErrorWithMessage` "found more than one OnDelete action, tokens: [\"OnDeleteCascade\",\"OnDeleteCascade\"]" @@ -404,7 +410,7 @@ name Text age Int |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user" let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user)) @@ -424,7 +430,7 @@ name Text age Int |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions errMsg = [st|expected only one Id declaration per entity|] evaluate (unboundEntityDef user) `shouldErrorWithMessage` (T.unpack errMsg) @@ -438,7 +444,7 @@ age Int Primary ref |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user" let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user)) @@ -472,7 +478,7 @@ Primary ref Primary name |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions errMsg = "expected only one Primary declaration per entity" evaluate (unboundEntityDef user) `shouldErrorWithMessage` errMsg @@ -486,7 +492,7 @@ age Int Primary ref |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions errMsg = [st|Specified both an ID field and a Primary field|] evaluate (unboundEntityDef user) `shouldErrorWithMessage` (T.unpack errMsg) @@ -497,7 +503,7 @@ age Text Primary ref |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions case unboundPrimarySpec user of NaturalKey ucd -> do evaluate (NEL.head $ unboundCompositeCols ucd) `shouldErrorWithMessage` @@ -514,7 +520,7 @@ UniqueEmail emailFirst emailSecond |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions uniques = entityUniques (unboundEntityDef user) [dbNames] = fmap snd . uniqueFields <$> uniques errMsg = unwords @@ -530,7 +536,7 @@ age Text Unique some |] - let [user] = parse lowerCaseSettings definitions + let [user] = defs definitions evaluate (unboundPrimarySpec user) `shouldErrorWithMessage` "invalid unique constraint on table[\"User\"] expecting an uppercase constraint name xs=[\"some\"]" @@ -556,7 +562,7 @@ flippedFK (EntityNameHS entName) (ConstraintNameHS conName) = conName <> entName [_user, notification] = - parse (setPsToFKName flippedFK lowerCaseSettings) validDefinitions + parse (setPsToFKName flippedFK lowerCaseSettings) [(Nothing, validDefinitions)] [notificationForeignDef] = unboundForeignDef <$> unboundForeignDefs notification foreignConstraintNameDBName notificationForeignDef @@ -578,7 +584,7 @@ sentToSecond Text Foreign User |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [_user, notification] = defsSnake definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] expecting a lower case constraint name or a cascading action xs=[]" @@ -598,7 +604,7 @@ sentToSecond Text Foreign User fk_noti_user |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [_user, notification] = defsSnake definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "No fields on foreign reference." @@ -618,7 +624,7 @@ sentToSecond Text Foreign User fk_noti_user sentToFirst sentToSecond References emailFirst |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [_user, notification] = defsSnake definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] Found 2 foreign fields but 1 parent fields" @@ -638,7 +644,7 @@ sentToSecond Text Foreign User OnDeleteCascade OnDeleteCascade |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [_user, notification] = defsSnake definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnDelete actions" @@ -658,14 +664,14 @@ sentToSecond Text Foreign User OnUpdateCascade OnUpdateCascade |] - let [_user, notification] = parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) definitions + let [_user, notification] = defsSnake definitions mapM (evaluate . unboundForeignFields) (unboundForeignDefs notification) `shouldErrorWithMessage` "invalid foreign key constraint on table[\"Notification\"] found more than one OnUpdate actions" it "should allow you to enable snake cased foriegn keys via a preset configuration function" $ do let [_user, notification] = - parse (setPsUseSnakeCaseForiegnKeys lowerCaseSettings) validDefinitions + defsSnake validDefinitions [notificationForeignDef] = unboundForeignDef <$> unboundForeignDefs notification foreignConstraintNameDBName notificationForeignDef @@ -683,7 +689,7 @@ currencyCode CurrencyCode uuid TransferUuid |] - let [customerTransfer] = parse lowerCaseSettings tickedDefinition + let [customerTransfer] = defs tickedDefinition let expectedType = FTTypeCon Nothing "MoneyAmount" `FTApp` FTTypePromoted "Customer" `FTApp` FTTypePromoted "Debit" @@ -703,7 +709,7 @@ one (Finite 1) twenty (Labelled "twenty") |] - let [withFinite] = parse lowerCaseSettings tickedDefinition + let [withFinite] = defs tickedDefinition (simplifyField <$> unboundEntityFields withFinite) `shouldBe` [ (FieldNameHS "one", FTApp (FTTypeCon Nothing "Finite") (FTLit (IntTypeLit 1))) @@ -776,7 +782,7 @@ let preparsed = preparse subject it "preparse works" $ do - (length <$> preparsed) `shouldBe` Just 10 + (length . snd <$> preparsed) `shouldBe` Just 10 let fooLines = [ Line @@ -829,7 +835,7 @@ let linesAssociated = - case preparsed of + case snd <$> preparsed of Nothing -> error "preparsed failed" Just lines -> associateLines lines it "associateLines works" $ do @@ -868,7 +874,7 @@ "more entities parsed than expected" result = - parse lowerCaseSettings subject + defs subject length result `shouldBe` 4 test @@ -891,7 +897,7 @@ [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] } , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] } ] - preparse "Person\n name String\n age Int" `shouldBe` Just expected + preparse "Person\n name String\n age Int" `shouldBe` Just (3, expected) it "recognizes comments" $ do let text = "Foo\n x X\n-- | Hello\nBar\n name String" @@ -902,7 +908,7 @@ , Line { lineIndent = 0, tokens = pure (Token "Bar") } , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] } ] - preparse text `shouldBe` Just expected + preparse text `shouldBe` Just (5, expected) it "preparse indented" $ do let t = T.unlines @@ -920,7 +926,7 @@ , Line { lineIndent = 2, tokens = pure (Token "Bar") } , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] } ] - preparse t `shouldBe` Just expected + preparse t `shouldBe` Just (6, expected) it "preparse extra blocks" $ do let t = T.unlines @@ -941,7 +947,7 @@ , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") } , Line { lineIndent = 4, tokens = pure (Token "something") } ] - preparse t `shouldBe` Just expected + preparse t `shouldBe` Just (7, expected) it "field comments" $ do let text = T.unlines @@ -956,7 +962,7 @@ , Line { lineIndent = 2, tokens = [DocComment "Field"] } , Line { lineIndent = 2, tokens = (Token <$> ["name", "String"]) } ] - preparse text `shouldBe` Just expected + preparse text `shouldBe` Just (4, expected) describe "associateLines" $ do let foo = @@ -1015,7 +1021,7 @@ } ] it "works with textual input" $ do - let text = preparse "Foo\n x X\n-- | Hello\nBar\n name String" + let text = snd <$> preparse "Foo\n x X\n-- | Hello\nBar\n name String" associateLines <$> text `shouldBe` Just [ LinesWithComments @@ -1034,7 +1040,7 @@ } ] it "works with extra blocks" $ do - let text = preparse . T.unlines $ + let text = fmap snd . preparse . T.unlines $ [ "LowerCaseTable" , " Id sql=my_id" , " fullName Text" @@ -1063,7 +1069,7 @@ ] it "works with extra blocks twice" $ do - let text = preparse . T.unlines $ + let text = fmap snd . preparse . T.unlines $ [ "IdTable" , " Id Day default=CURRENT_DATE" , " name Text" @@ -1104,7 +1110,7 @@ it "works with field comments" $ do - let text = preparse . T.unlines $ + let text = fmap snd . preparse . T.unlines $ [ "-- | Model" , "Foo" , " -- | Field" @@ -1138,7 +1144,7 @@ , " Extra2" , " something" ] - let [subject] = parse lowerCaseSettings lines + let [subject] = defs lines it "produces the right name" $ do getUnboundEntityNameHS subject `shouldBe` EntityNameHS "Foo" describe "unboundEntityFields" $ do @@ -1163,7 +1169,7 @@ ] describe "works with extra blocks" $ do let [_, lowerCaseTable, idTable] = - case parse lowerCaseSettings $ T.unlines + case defs $ T.unlines [ "" , "IdTable" , " Id Day default=CURRENT_DATE" diff --git a/test/Database/Persist/THSpec.hs b/test/Database/Persist/THSpec.hs --- a/test/Database/Persist/THSpec.hs +++ b/test/Database/Persist/THSpec.hs @@ -35,6 +35,7 @@ import Data.Text (Text, pack) import Data.Time import GHC.Generics (Generic) +import qualified Language.Haskell.TH.Syntax as TH import System.Environment import Test.Hspec import Test.Hspec.QuickCheck @@ -43,12 +44,12 @@ import Database.Persist import Database.Persist.EntityDef.Internal +import Database.Persist.Quasi.Internal (SourceLoc(..), sourceLocFromTHLoc) import Database.Persist.Sql import Database.Persist.Sql.Util import Database.Persist.TH import TemplateTestImports - import qualified Database.Persist.TH.CommentSpec as CommentSpec import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec @@ -76,6 +77,10 @@ -- machinery type TextId = Text +-- | Location above the block defining Person below. Must be before it. Do not move! +-- Used to test TH definition positions are plausible. +personDefBeforeLoc :: SourceLoc +personDefBeforeLoc = $(TH.lift . sourceLocFromTHLoc =<< TH.location) share [mkPersistWith sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] } [entityDef @JsonEncodingSpec.JsonEncoding Proxy]] [persistUpperCase| Person json @@ -107,6 +112,10 @@ jsonEncoding JsonEncodingSpec.JsonEncodingId |] +-- | Location after the block defining Person above. Must be after it. Do not move! +-- Used to test TH definition positions are plausible. +personDefAfterLoc :: SourceLoc +personDefAfterLoc = $(TH.lift . sourceLocFromTHLoc =<< TH.location) mkPersist sqlSettings [persistLowerCase| HasPrimaryDef @@ -325,6 +334,11 @@ , fcOnUpdate = Nothing } describe "entityDef" $ do + it "correct position" $ do + let Just theSpan = entitySpan simpleCascadeDef + theSpan `shouldSatisfy` ((> locStartLine personDefBeforeLoc) . spanStartLine) + theSpan `shouldSatisfy` (\s -> spanStartLine s < spanEndLine s) + theSpan `shouldSatisfy` ((< locStartLine personDefAfterLoc) . spanEndLine) it "works" $ do simpleCascadeDef `shouldBe` @@ -371,6 +385,10 @@ , entityExtra = mempty , entitySum = False , entityComments = Nothing + -- We cannot test this is a precise value without + -- being really fragile, but we have another test to + -- verify the line is in range. + , entitySpan = entitySpan simpleCascadeDef } it "has the cascade on the field def" $ do fieldCascade subject `shouldBe` expected