diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ ## Unreleased changes +## 2.12.0.0 + +* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) +* [#1214](https://github.com/yesodweb/persistent/pull/1214): + * This package was asborbed into `persistent` itself. + ## 2.9.1.0 * [#1145](https://github.com/yesodweb/persistent/pull/1148) diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs deleted file mode 100644 --- a/Database/Persist/TH.hs +++ /dev/null @@ -1,2019 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveLift #-} - -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} - --- | This module provides the tools for defining your database schema and using --- it to generate Haskell data types and migrations. -module Database.Persist.TH - ( -- * Parse entity defs - persistWith - , persistUpperCase - , persistLowerCase - , persistFileWith - , persistManyFileWith - -- * Turn @EntityDef@s into types - , mkPersist - , MkPersistSettings - , mpsBackend - , mpsGeneric - , mpsPrefixFields - , mpsFieldLabelModifier - , mpsConstraintLabelModifier - , mpsEntityJSON - , mpsGenerateLenses - , mpsDeriveInstances - , EntityJSON(..) - , mkPersistSettings - , sqlSettings - -- * Various other TH functions - , mkMigrate - , mkSave - , mkDeleteCascade - , 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 ((++), take, concat, splitAt, exp) - -import Data.Either -import Control.Monad -import Data.Aeson - ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object - , Value (Object), (.:), (.:?) - , eitherDecodeStrict' - ) -import qualified Data.ByteString as BS -import Data.Typeable (Typeable) -import Data.Ix (Ix) -import Data.Data (Data) -import Data.Char (toLower, toUpper) -import qualified Data.HashMap.Strict as HM -import Data.Int (Int64) -import Data.List (foldl') -import qualified Data.List as List -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as M -import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) -import Data.Monoid ((<>), mappend, mconcat) -import Data.Proxy (Proxy (Proxy)) -import Data.Text (pack, Text, append, unpack, concat, uncons, cons, stripSuffix) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8) -import qualified Data.Text.Encoding as TE -import GHC.Generics (Generic) -import GHC.TypeLits -import Instances.TH.Lift () - -- Bring `Lift (Map k v)` instance into scope, as well as `Lift Text` - -- instance on pre-1.2.4 versions of `text` -import Language.Haskell.TH.Lib (appT, varT, conT, varE, varP, conE, litT, strTyLit) -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax -import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) -import qualified Data.Set as Set - -import Database.Persist -import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) -import Database.Persist.Quasi - --- | This special-cases "type_" and strips out its underscore. When --- used for JSON serialization and deserialization, it works around --- -unHaskellNameForJSON :: HaskellName -> Text -unHaskellNameForJSON = fixTypeUnderscore . unHaskellName - where - fixTypeUnderscore = \case - "type" -> "type_" - name -> name - --- | 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 - } - --- | 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 --- 'share' --- ['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] -> [EntityDef] -embedEntityDefs = snd . embedEntityDefsMap - -embedEntityDefsMap :: [EntityDef] -> (M.Map HaskellName EmbedEntityDef, [EntityDef]) -embedEntityDefsMap rawEnts = (embedEntityMap, noCycleEnts) - where - noCycleEnts = map breakCycleEnt entsWithEmbeds - -- every EntityDef could reference each-other (as an EmbedRef) - -- let Haskell tie the knot - embedEntityMap = constructEmbedEntityMap entsWithEmbeds - entsWithEmbeds = map setEmbedEntity rawEnts - setEmbedEntity ent = ent - { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent - } - - -- self references are already broken - -- look at every emFieldEmbed to see if it refers to an already seen HaskellName - -- so start with entityHaskell ent and accumulate embeddedHaskell em - breakCycleEnt entDef = - let entName = entityHaskell entDef - in entDef { entityFields = map (breakCycleField entName) $ entityFields entDef } - - breakCycleField entName f = case f of - FieldDef { fieldReference = EmbedRef em } -> - f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em } - _ -> - f - - breakCycleEmbed ancestors em = - em { embeddedFields = breakCycleEmField (emName : ancestors) <$> embeddedFields em - } - where - emName = embeddedHaskell em - - breakCycleEmField ancestors emf = case embeddedHaskell <$> membed of - Nothing -> emf - Just embName -> if embName `elem` ancestors - then emf { emFieldEmbed = Nothing, emFieldCycle = Just embName } - else emf { emFieldEmbed = breakCycleEmbed ancestors <$> membed } - where - membed = emFieldEmbed emf - --- calls parse to Quasi.parse individual entities in isolation --- afterwards, sets references to other entities --- | @since 2.5.3 -parseReferences :: PersistSettings -> Text -> Q Exp -parseReferences ps s = lift $ - map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts - where - (embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s - entityMap = constructEntityMap noCycleEnts - -stripId :: FieldType -> Maybe Text -stripId (FTTypeCon Nothing t) = stripSuffix "Id" t -stripId _ = Nothing - -foreignReference :: FieldDef -> Maybe HaskellName -foreignReference field = case fieldReference field of - ForeignRef ref _ -> Just ref - _ -> Nothing - - --- fieldSqlType at parse time can be an Exp --- This helps delay setting fieldSqlType until lift time -data EntityDefSqlTypeExp - = EntityDefSqlTypeExp EntityDef SqlTypeExp [SqlTypeExp] - deriving Show - -data SqlTypeExp - = SqlTypeExp FieldType - | SqlType' SqlType - deriving Show - -instance Lift SqlTypeExp where - lift (SqlType' t) = lift t - lift (SqlTypeExp ftype) = return st - where - typ = ftToType ftype - mtyp = ConT ''Proxy `AppT` typ - typedNothing = SigE (ConE 'Proxy) mtyp - st = VarE 'sqlType `AppE` typedNothing -#if MIN_VERSION_template_haskell(2,16,0) - liftTyped = unsafeTExpCoerce . lift -#endif - -data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp] - -instance Lift FieldsSqlTypeExp where - lift (FieldsSqlTypeExp fields sqlTypeExps) = - lift $ zipWith FieldSqlTypeExp fields sqlTypeExps -#if MIN_VERSION_template_haskell(2,16,0) - liftTyped = unsafeTExpCoerce . lift -#endif - -data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp - -instance Lift FieldSqlTypeExp where - lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) = - [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs fieldStrict fieldReference fieldCascade fieldComments fieldGenerated|] - where - FieldDef _x _ _ _ _ _ _ _ _ _ = - error "need to update this record wildcard match" -#if MIN_VERSION_template_haskell(2,16,0) - liftTyped = unsafeTExpCoerce . lift -#endif - -instance Lift EntityDefSqlTypeExp where - lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) = - [|ent { entityFields = $(lift $ FieldsSqlTypeExp (entityFields ent) sqlTypeExps) - , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp) - } - |] -#if MIN_VERSION_template_haskell(2,16,0) - liftTyped = unsafeTExpCoerce . lift -#endif - -deriving instance Lift ReferenceDef - -deriving instance Lift EmbedEntityDef - -deriving instance Lift EmbedFieldDef - -type EmbedEntityMap = M.Map HaskellName EmbedEntityDef - -constructEmbedEntityMap :: [EntityDef] -> EmbedEntityMap -constructEmbedEntityMap = - M.fromList . fmap (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) - -type EntityMap = M.Map HaskellName EntityDef - -constructEntityMap :: [EntityDef] -> EntityMap -constructEntityMap = - M.fromList . fmap (\ent -> (entityHaskell ent, ent)) - -data FTTypeConDescr = FTKeyCon - 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 - :: EmbedEntityMap - -> FieldType - -> Either (Maybe FTTypeConDescr) EmbedEntityDef -mEmbedded _ (FTTypeCon Just{} _) = - Left Nothing -mEmbedded ents (FTTypeCon Nothing (HaskellName -> name)) = - maybe (Left Nothing) Right $ M.lookup name ents -mEmbedded ents (FTList x) = - mEmbedded ents x -mEmbedded ents (FTApp x y) = - -- Key converts an Record to a RecordId - -- special casing this is obviously a hack - -- This problem may not be solvable with the current QuasiQuoted approach though - if x == FTTypeCon Nothing "Key" - then Left $ Just FTKeyCon - else mEmbedded ents y - -setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef -setEmbedField entName allEntities field = field - { fieldReference = - case fieldReference field of - NoReference -> - case mEmbedded allEntities (fieldType field) of - Left _ -> - case stripId $ fieldType field of - Nothing -> - NoReference - Just name -> - case M.lookup (HaskellName name) allEntities of - Nothing -> - NoReference - Just _ -> - ForeignRef - (HaskellName name) - -- This can get corrected in mkEntityDefSqlTypeExp - (FTTypeCon (Just "Data.Int") "Int64") - Right em -> - if embeddedHaskell em /= entName - then EmbedRef em - else if maybeNullable field - then SelfReference - else case fieldType field of - FTList _ -> SelfReference - _ -> error $ unpack $ unHaskellName entName <> ": a self reference must be a Maybe" - existing -> - existing - } - -mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp -mkEntityDefSqlTypeExp emEntities entityMap ent = - EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $ entityFields ent) - where - getSqlType field = - maybe - (defaultSqlTypeExp field) - (SqlType' . SqlOther) - (listToMaybe $ mapMaybe (\case {FieldAttrSqltype x -> Just x; _ -> Nothing}) $ fieldAttrs 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 field = - case mEmbedded emEntities ftype of - Right _ -> - SqlType' SqlString - Left (Just FTKeyCon) -> - SqlType' SqlString - Left Nothing -> - case fieldReference field of - ForeignRef refName ft -> - case M.lookup refName entityMap of - Nothing -> SqlTypeExp ft - -- A ForeignRef is blindly set to an Int64 in setEmbedField - -- correct that now - Just ent' -> - case entityPrimary ent' of - Nothing -> SqlTypeExp ft - Just pdef -> - case compositeFields pdef of - [] -> error "mkEntityDefSqlTypeExp: no composite fields" - [x] -> SqlTypeExp $ fieldType x - _ -> SqlType' $ SqlOther "Composite Reference" - CompositeRef _ -> - SqlType' $ SqlOther "Composite Reference" - _ -> - 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 = fieldType field - --- | Create data types and appropriate 'PersistEntity' instances for the given --- 'EntityDef's. Works well with the persist quasi-quoter. -mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] -mkPersist mps ents' = do - requireExtensions - [ [TypeFamilies], [GADTs, ExistentialQuantification] - , [DerivingStrategies], [GeneralizedNewtypeDeriving], [StandaloneDeriving] - , [UndecidableInstances], [DataKinds], [FlexibleInstances] - ] - x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents - y <- fmap mconcat $ mapM (mkEntity entityMap mps) ents - z <- fmap mconcat $ mapM (mkJSON mps) ents - uniqueKeyInstances <- fmap mconcat $ mapM (mkUniqueKeyInstances mps) ents - symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances mps) ents - return $ mconcat [x, y, z, uniqueKeyInstances, symbolToFieldInstances] - where - ents = map fixEntityDef ents' - entityMap = constructEntityMap ents - --- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'. --- For example, strip out any fields marked as MigrationOnly. -fixEntityDef :: EntityDef -> EntityDef -fixEntityDef ed = - ed { entityFields = filter keepField $ entityFields ed } - where - keepField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd && - FieldAttrSafeToRemove `notElem` fieldAttrs fd - --- | Settings to be passed to the 'mkPersist' function. -data MkPersistSettings = MkPersistSettings - { mpsBackend :: Type - -- ^ Which database backend we\'re using. - -- - -- When generating data types, each type is given a generic version- which - -- works with any backend- and a type synonym for the commonly used - -- backend. This is where you specify that commonly used backend. - , 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 - , 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 - , 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 - } - -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 t = MkPersistSettings - { mpsBackend = t - , mpsGeneric = False - , mpsPrefixFields = True - , mpsFieldLabelModifier = (++) - , mpsConstraintLabelModifier = (++) - , mpsEntityJSON = Just EntityJSON - { entityToJSON = 'entityIdToJSON - , entityFromJSON = 'entityIdFromJSON - } - , mpsGenerateLenses = False - , mpsDeriveInstances = [] - } - --- | Use the 'SqlPersist' backend. -sqlSettings :: MkPersistSettings -sqlSettings = mkPersistSettings $ ConT ''SqlBackend - -recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text -recNameNoUnderscore mps dt f - | mpsPrefixFields mps = lowerFirst $ modifier (unHaskellName dt) (upperFirst ft) - | otherwise = lowerFirst ft - where - modifier = mpsFieldLabelModifier mps - ft = unHaskellName f - -recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text -recName mps dt f = - addUnderscore $ recNameNoUnderscore mps dt f - where - addUnderscore - | mpsGenerateLenses mps = ("_" ++) - | otherwise = id - -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 -> EntityDef -> Q Dec -dataTypeDec mps t = do - let entityInstances = map (mkName . unpack) $ entityDerives t - additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps - names = entityInstances <> additionalInstances - - let (stocks, anyclasses) = partitionEithers (map stratFor names) - let stockDerives = do - guard (not (null stocks)) - pure (DerivClause (Just StockStrategy) (map ConT stocks)) - anyclassDerives = do - guard (not (null anyclasses)) - pure (DerivClause (Just AnyclassStrategy) (map ConT anyclasses)) - unless (null anyclassDerives) $ do - requireExtensions [[DeriveAnyClass]] - pure $ DataD [] nameFinal paramsFinal - Nothing - constrs - (stockDerives <> anyclassDerives) - where - stratFor n = - if n `elem` stockClasses then - Left n - else - Right n - - stockClasses = - Set.fromList (map mkName - [ "Eq", "Ord", "Show", "Read", "Bounded", "Enum", "Ix", "Generic", "Data", "Typeable" - ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable - ] - ) - mkCol x fd@FieldDef {..} = - (mkName $ unpack $ recName mps x fieldHaskell, - if fieldStrict then isStrict else notStrict, - maybeIdType mps fd Nothing Nothing - ) - (nameFinal, paramsFinal) - | mpsGeneric mps = (nameG, [PlainTV backend]) - | otherwise = (name, []) - nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic" - name = mkName $ unpack $ unHaskellName $ entityHaskell t - cols = map (mkCol $ entityHaskell t) $ entityFields t - backend = backendName - - constrs - | entitySum t = map sumCon $ entityFields t - | otherwise = [RecC name cols] - - sumCon fd = NormalC - (sumConstrName mps t fd) - [(notStrict, maybeIdType mps fd Nothing Nothing)] - -sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -sumConstrName mps t FieldDef {..} = mkName $ unpack name - where - name - | mpsPrefixFields mps = modifiedName ++ "Sum" - | otherwise = fieldName ++ "Sum" - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unHaskellName $ entityHaskell t - fieldName = upperFirst $ unHaskellName fieldHaskell - -uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec -uniqueTypeDec mps t = -#if MIN_VERSION_template_haskell(2,15,0) - DataInstD [] Nothing - (AppT (ConT ''Unique) (genericDataType mps (entityHaskell t) backendT)) - Nothing - (map (mkUnique mps t) $ entityUniques t) - [] -#else - DataInstD [] ''Unique - [genericDataType mps (entityHaskell t) backendT] - Nothing - (map (mkUnique mps t) $ entityUniques t) - [] -#endif - -mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con -mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) = - NormalC (mkName $ unpack constr) types - where - types = - map (go . flip lookup3 (entityFields t) . unHaskellName . fst) fields - - force = "!force" `elem` attrs - - go :: (FieldDef, IsNullable) -> (Strict, Type) - go (_, Nullable _) | not force = error nullErrMsg - go (fd, y) = (notStrict, maybeIdType mps fd Nothing (Just y)) - - lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) - lookup3 s [] = - error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr - lookup3 x (fd@FieldDef {..}:rest) - | x == unHaskellName fieldHaskell = (fd, nullable fieldAttrs) - | otherwise = lookup3 x rest - - nullErrMsg = - mconcat [ "Error: By default we disallow NULLables in an uniqueness " - , "constraint. The semantics of how NULL interacts with those " - , "constraints is non-trivial: two NULL values are not " - , "considered equal for the purposes of an uniqueness " - , "constraint. If you understand this feature, it is possible " - , "to use it your advantage. *** Use a \"!force\" attribute " - , "on the end of the line that defines your uniqueness " - , "constraint in order to disable this check. ***" ] - -maybeIdType :: MkPersistSettings - -> FieldDef - -> Maybe Name -- ^ backend - -> Maybe IsNullable - -> Type -maybeIdType mps fd mbackend mnull = maybeTyp mayNullable idtyp - where - mayNullable = case mnull of - (Just (Nullable ByMaybeAttr)) -> True - _ -> maybeNullable fd - idtyp = idType mps fd mbackend - -backendDataType :: MkPersistSettings -> Type -backendDataType mps - | mpsGeneric mps = backendT - | otherwise = mpsBackend mps - -genericDataType :: MkPersistSettings - -> HaskellName -- ^ entity name - -> Type -- ^ backend - -> Type -genericDataType mps (HaskellName typ') backend - | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend - | otherwise = ConT $ mkName $ unpack typ' - -idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type -idType mps fd mbackend = - case foreignReference fd of - Just typ -> - ConT ''Key - `AppT` genericDataType mps typ (VarT $ fromMaybe backendName mbackend) - Nothing -> ftToType $ fieldType fd - -degen :: [Clause] -> [Clause] -degen [] = - let err = VarE 'error `AppE` LitE (StringL - "Degenerate case, should never happen") - in [normalClause [WildP] err] -degen x = x - -mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec -mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do - 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 pat = ConP (mkName constr) $ map VarP xs - sp <- [|SomePersistField|] - let bod = ListE $ map (AppE sp . VarE) xs - return $ normalClause [pat] bod - - fieldCount = length fields - - goSum :: FieldDef -> Int -> Q Clause - goSum fd idx = do - let name = sumConstrName mps ed fd - enull <- [|SomePersistField PersistNull|] - let beforeCount = idx - 1 - afterCount = fieldCount - idx - before = replicate beforeCount enull - after = replicate afterCount enull - x <- newName "x" - sp <- [|SomePersistField|] - 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 (mkName $ unpack $ unHaskellName 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 (mkName $ unpack $ unHaskellName constr) $ map VarP xs - tpv <- [|toPersistValue|] - let bod = ListE $ map (AppE tpv . VarE) 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) - -mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause] -mkFromPersistValues _ t@(EntityDef { entitySum = False }) = - fromValues t "fromPersistValues" entE $ entityFields t - where - entE = ConE $ mkName $ unpack entName - entName = unHaskellName $ entityHaskell t - -mkFromPersistValues mps t@(EntityDef { entitySum = True }) = do - nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] - clauses <- mkClauses [] $ entityFields t - return $ clauses `mappend` [normalClause [WildP] nothing] - where - entName = unHaskellName $ entityHaskell t - mkClauses _ [] = return [] - mkClauses before (field:after) = do - x <- newName "x" - let null' = ConP 'PersistNull [] - pat = ListP $ mconcat - [ map (const null') before - , [VarP x] - , map (const null') after - ] - constr = ConE $ sumConstrName mps t 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 - -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 - -mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause] -mkLensClauses mps t = 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 t) []] - (lens' `AppE` getId `AppE` setId) - if entitySum t - then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields t) - else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields t) - where - toClause lens' getVal dot keyVar valName xName f = normalClause - [ConP (filterConName mps t f) []] - (lens' `AppE` getter `AppE` setter) - where - fieldName = mkName $ unpack $ recName mps (entityHaskell t) (fieldHaskell f) - getter = InfixE (Just $ VarE fieldName) dot (Just getVal) - setter = LamE - [ ConP 'Entity [VarP keyVar, VarP valName] - , VarP xName - ] - $ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE - (VarE valName) - [(fieldName, VarE xName)] - - toSumClause lens' keyVar valName xName f = normalClause - [ConP (filterConName mps t f) []] - (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 t f) [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 (entityFields t) > 1 then [emptyMatch] else [] - setter = LamE - [ ConP 'Entity [VarP keyVar, WildP] - , VarP xName - ] - $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps t f) `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 -> EntityDef -> Q (Dec, [Dec]) -mkKeyTypeDec mps t = 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 = map (\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 t - unKeyE = unKeyExp t - dec = RecC (keyConName t) (keyFields mps t) - k = ''Key - recordType = genericDataType mps (entityHaskell t) 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 - - instances <- do - 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)) - |] - - if customKeyType then return alwaysInstances - else fmap (alwaysInstances `mappend`) backendKeyGenericI - return instances - - useNewtype = pkNewtype mps t - customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t) - - supplement :: [Name] -> [Name] - supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) - -keyIdName :: EntityDef -> Name -keyIdName = mkName . unpack . keyIdText - -keyIdText :: EntityDef -> Text -keyIdText t = unHaskellName (entityHaskell t) `mappend` "Id" - -unKeyName :: EntityDef -> Name -unKeyName t = mkName $ "un" `mappend` keyString t - -unKeyExp :: EntityDef -> Exp -unKeyExp = VarE . unKeyName - -backendT :: Type -backendT = VarT backendName - -backendName :: Name -backendName = mkName "backend" - -keyConName :: EntityDef -> Name -keyConName t = mkName $ resolveConflict $ keyString t - where - resolveConflict kn = if conflict then kn `mappend` "'" else kn - conflict = any ((== HaskellName "key") . fieldHaskell) $ entityFields t - -keyConExp :: EntityDef -> Exp -keyConExp = ConE . keyConName - -keyString :: EntityDef -> String -keyString = unpack . keyText - -keyText :: EntityDef -> Text -keyText t = unHaskellName (entityHaskell t) ++ "Key" - --- | Returns 'True' if the key definition has more than 1 field. --- --- @since 2.11.0.0 -pkNewtype :: MkPersistSettings -> EntityDef -> Bool -pkNewtype mps t = length (keyFields mps t) < 2 - -defaultIdType :: EntityDef -> Bool -defaultIdType t = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t) - -keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)] -keyFields mps t = case entityPrimary t of - Just pdef -> map primaryKeyVar (compositeFields pdef) - Nothing -> if defaultIdType t - then [idKeyVar backendKeyType] - else [idKeyVar $ ftToType $ fieldType $ entityId t] - where - backendKeyType - | mpsGeneric mps = ConT ''BackendKey `AppT` backendT - | otherwise = ConT ''BackendKey `AppT` mpsBackend mps - idKeyVar ft = (unKeyName t, notStrict, ft) - primaryKeyVar fd = ( keyFieldName mps t fd - , notStrict - , ftToType $ fieldType fd - ) - -keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -keyFieldName mps t fd - | pkNewtype mps t = unKeyName t - | otherwise = mkName $ unpack $ lowerFirst (keyText t) `mappend` unHaskellName (fieldHaskell fd) - -mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec -mkKeyToValues mps t = do - (p, e) <- case entityPrimary t of - Nothing -> - ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|] - Just pdef -> - return $ toValuesPrimary pdef - return $ FunD 'keyToValues $ return $ normalClause p e - where - toValuesPrimary pdef = - ( [VarP recordName] - , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps t fd) `AppE` VarE recordName)) $ compositeFields pdef - ) - recordName = mkName "record" - -normalClause :: [Pat] -> Exp -> Clause -normalClause p e = Clause p (NormalB e) [] - -mkKeyFromValues :: MkPersistSettings -> EntityDef -> Q Dec -mkKeyFromValues _mps t = do - clauses <- case entityPrimary t of - Nothing -> do - e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] - return [normalClause [] e] - Just pdef -> - fromValues t "keyFromValues" keyConE (compositeFields pdef) - return $ FunD 'keyFromValues clauses - where - keyConE = keyConExp t - -headNote :: [PersistValue] -> PersistValue -headNote = \case - [x] -> x - xs -> error $ "mkKeyFromValues: expected a list of one element, got: " `mappend` show xs - -fromValues :: EntityDef -> Text -> Exp -> [FieldDef] -> Q [Clause] -fromValues t funName conE fields = do - x <- newName "x" - let funMsg = entityText t `mappend` ": " `mappend` funName `mappend` " failed on: " - patternMatchFailure <- [|Left $ mappend funMsg (pack $ show $(return $ VarE x))|] - suc <- patternSuccess - return [ suc, normalClause [VarP x] patternMatchFailure ] - where - tableName = unDBName (entityDB t) - patternSuccess = - case fields of - [] -> do - rightE <- [|Right|] - return $ normalClause [ListP []] (rightE `AppE` conE) - _ -> 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 conE x1 - applyE <- [|(<*>)|] - let applyFromPersistValue = infixFromPersistValue applyE - - return $ normalClause - [ListP $ map VarP (x1:restNames)] - (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 = (unHaskellName (fieldHaskell 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 :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] -mkEntity entityMap mps t = do - t' <- liftAndFixKeys entityMap t - let nameT = unHaskellName entName - let nameS = unpack nameT - let clazz = ConT ''PersistEntity `AppT` genDataType - tpf <- mkToPersistFields mps nameS t - fpv <- mkFromPersistValues mps t - utv <- mkUniqueToValues $ entityUniques t - puk <- mkUniqueKeys t - let primaryField = entityId t - fields <- mapM (mkField mps t) $ primaryField : entityFields t - fkc <- mapM (mkForeignKeysComposite mps t) $ entityForeigns t - - - toFieldNames <- mkToFieldNames $ entityUniques t - - (keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t - keyToValues' <- mkKeyToValues mps t - keyFromValues' <- mkKeyFromValues mps t - - let addSyn -- FIXME maybe remove this - | mpsGeneric mps = (:) $ - TySynD (mkName nameS) [] $ - genericDataType mps entName $ mpsBackend mps - | otherwise = id - - lensClauses <- mkLensClauses mps t - - lenses <- mkLenses mps t - let instanceConstraint = if not (mpsGeneric mps) then [] else - [mkClassP ''PersistStore [backendT]] - - [keyFromRecordM'] <- - case entityPrimary t of - Just prim -> do - recordName <- newName "record" - let keyCon = keyConName t - keyFields' = - map (mkName . T.unpack . recName mps entName . fieldHaskell) - (compositeFields prim) - constr = - foldl' - AppE - (ConE keyCon) - (map - (\n -> - VarE n `AppE` VarE recordName - ) - keyFields' - ) - keyFromRec = varP 'keyFromRecordM - [d|$(keyFromRec) = Just ( \ $(varP recordName) -> $(pure constr)) |] - - Nothing -> - [d|$(varP 'keyFromRecordM) = Nothing|] - - dtd <- dataTypeDec mps t - return $ addSyn $ - dtd : mconcat fkc `mappend` - ([ TySynD (keyIdName t) [] $ - ConT ''Key `AppT` ConT (mkName nameS) - , instanceD instanceConstraint clazz - [ uniqueTypeDec mps t - , keyTypeDec - , keyToValues' - , keyFromValues' - , keyFromRecordM' - , FunD 'entityDef [normalClause [WildP] t'] - , 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 - (map fst fields) - [] -#else - , DataInstD - [] - ''EntityField - [ genDataType - , VarT $ mkName "typ" - ] - Nothing - (map fst fields) - [] -#endif - , FunD 'persistFieldDef (map snd fields) -#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 t)] - , FunD 'fieldLens lensClauses - ] - ] `mappend` lenses) `mappend` keyInstanceDecs - where - genDataType = genericDataType mps entName backendT - entName = entityHaskell t - -mkUniqueKeyInstances :: MkPersistSettings -> EntityDef -> Q [Dec] -mkUniqueKeyInstances mps t = do - requirePersistentExtensions - case entityUniques t 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 (VarT $ mkName "backend")) |] - 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 <- typeErrorMultipleCtx - 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 (entityHaskell t) backendT - - -entityText :: EntityDef -> Text -entityText = unHaskellName . entityHaskell - -mkLenses :: MkPersistSettings -> EntityDef -> Q [Dec] -mkLenses mps _ | not (mpsGenerateLenses mps) = return [] -mkLenses _ ent | entitySum ent = return [] -mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do - let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) - lensName = mkName $ unpack lensName' - fieldName = mkName $ unpack $ "_" ++ lensName' - 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 field (Just backend1) Nothing - bT = maybeIdType mps field (Just backend2) Nothing - mkST backend = genericDataType mps (entityHaskell ent) (VarT backend) - sT = mkST backend1 - tT = mkST backend2 - t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2 - vars = PlainTV fT - : (if mpsGeneric mps then [PlainTV backend1{-, PlainTV backend2-}] else []) - 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 [] (VarE fieldName `AppE` a)] - , FunD setterN $ return $ normalClause - [VarP yN] - (RecUpdE a - [ (fieldName, y) - ]) - ] - ] - -mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] -mkForeignKeysComposite mps t ForeignDef {..} = - if not foreignToPrimary then return [] else do - let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f - let fname = fieldName foreignConstraintNameHaskell - let reftableString = unpack $ unHaskellName foreignRefTableHaskell - let reftableKeyName = mkName $ reftableString `mappend` "Key" - let tablename = mkName $ unpack $ entityText t - recordName <- newName "record" - - let mkFldE ((foreignName, _),ff) = case ff of - (HaskellName {unHaskellName = "Id"}, DBName {unDBName = "id"}) - -> AppE (VarE $ mkName "toBackendKey") $ - VarE (fieldName foreignName) `AppE` VarE recordName - _ -> VarE (fieldName foreignName) `AppE` VarE recordName - let fldsE = map mkFldE foreignFields - let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE - let fn = FunD fname [normalClause [VarP recordName] mkKeyE] - - let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString) - let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2 - return [sig, fn] - -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 = map (unHaskellName . fieldHaskell) (entityFields (entityDef (Just entity))) - fieldsAsPersistValues = map 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 $ map lookupPersistValueByColumnName columnNames - --- | Produce code similar to the following: --- --- @ --- instance PersistEntity e => PersistField e where --- toPersistValue = entityToPersistValueHelper --- fromPersistValue = entityFromPersistValueHelper ["col1", "col2"] --- sqlType _ = SqlString --- @ -persistFieldFromEntity :: MkPersistSettings -> EntityDef -> 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 entDef) backendT - entFields = entityFields entDef - columnNames = map (unpack . unHaskellName . fieldHaskell) entFields - --- | Apply the given list of functions to the same @EntityDef@s. --- --- This function is useful for cases such as: --- --- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|] -share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec] -share fs x = mconcat <$> mapM ($ x) fs - --- | Save the @EntityDef@s passed in under the given name. -mkSave :: String -> [EntityDef] -> Q [Dec] -mkSave name' defs' = do - let name = mkName name' - defs <- lift defs' - return [ SigD name $ ListT `AppT` ConT ''EntityDef - , FunD name [normalClause [] defs] - ] - -data Dep = Dep - { depTarget :: HaskellName - , depSourceTable :: HaskellName - , depSourceField :: HaskellName - , depSourceNull :: IsNullable - } - --- | Generate a 'DeleteCascade' instance for the given @EntityDef@s. -mkDeleteCascade :: MkPersistSettings -> [EntityDef] -> Q [Dec] -mkDeleteCascade mps defs = do - let deps = concatMap getDeps defs - mapM (go deps) defs - where - getDeps :: EntityDef -> [Dep] - getDeps def = - concatMap getDeps' $ entityFields $ fixEntityDef def - where - getDeps' :: FieldDef -> [Dep] - getDeps' field@FieldDef {..} = - case foreignReference field of - Just name -> - return Dep - { depTarget = name - , depSourceTable = entityHaskell def - , depSourceField = fieldHaskell - , depSourceNull = nullable fieldAttrs - } - Nothing -> [] - go :: [Dep] -> EntityDef -> Q Dec - go allDeps EntityDef{entityHaskell = name} = do - let deps = filter (\x -> depTarget x == name) allDeps - key <- newName "key" - let del = VarE 'delete - let dcw = VarE 'deleteCascadeWhere - just <- [|Just|] - filt <- [|Filter|] - eq <- [|Eq|] - value <- [|FilterValue|] - let mkStmt :: Dep -> Stmt - mkStmt dep = NoBindS - $ dcw `AppE` - ListE - [ filt `AppE` ConE filtName - `AppE` (value `AppE` val (depSourceNull dep)) - `AppE` eq - ] - where - filtName = filterConName' mps (depSourceTable dep) (depSourceField dep) - val (Nullable ByMaybeAttr) = just `AppE` VarE key - val _ = VarE key - - - - let stmts :: [Stmt] - stmts = map mkStmt deps `mappend` - [NoBindS $ del `AppE` VarE key] - - let entityT = genericDataType mps name backendT - - return $ - instanceD - [ mkClassP ''PersistQuery [backendT] - , mkEqualP (ConT ''PersistEntityBackend `AppT` entityT) (ConT ''BaseBackend `AppT` backendT) - ] - (ConT ''DeleteCascade `AppT` entityT `AppT` backendT) - [ FunD 'deleteCascade - [normalClause [VarP key] (DoE stmts)] - ] - --- | 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. - -> [EntityDef] - -> Q [Dec] -mkEntityDefList entityList entityDefs = do - let entityListName = mkName entityList - edefs <- fmap ListE - . forM entityDefs - $ \(EntityDef { entityHaskell = HaskellName haskellName }) -> - let entityType = conT (mkName (T.unpack haskellName)) - in [|entityDef (Proxy :: Proxy $(entityType))|] - typ <- [t|[EntityDef]|] - pure - [ SigD entityListName typ - , ValD (VarP entityListName) (NormalB edefs) [] - ] - -mkUniqueKeys :: EntityDef -> Q Dec -mkUniqueKeys def | entitySum def = - return $ FunD 'persistUniqueKeys [normalClause [WildP] (ListE [])] -mkUniqueKeys def = do - c <- clause - return $ FunD 'persistUniqueKeys [c] - where - clause = do - xs <- forM (entityFields def) $ \fd -> do - let x = fieldHaskell fd - x' <- newName $ '_' : unpack (unHaskellName x) - return (x, x') - let pcs = map (go xs) $ entityUniques def - let pat = ConP - (mkName $ unpack $ unHaskellName $ entityHaskell def) - (map (VarP . snd) xs) - return $ normalClause [pat] (ListE pcs) - - go :: [(HaskellName, Name)] -> UniqueDef -> Exp - go xs (UniqueDef name _ cols _) = - foldl' (go' xs) (ConE (mkName $ unpack $ unHaskellName name)) (map fst cols) - - go' :: [(HaskellName, Name)] -> Exp -> HaskellName -> Exp - go' xs front col = - let Just 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 - ] - ] - --- | 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. -mkMigrate :: String -> [EntityDef] -> Q [Dec] -mkMigrate fun allDefs = do - body' <- body - return - [ SigD (mkName fun) typ - , FunD (mkName fun) [normalClause [] body'] - ] - where - defs = filter isMigrated allDefs - isMigrated def = "no-migrate" `notElem` entityAttrs def - typ = ConT ''Migration - entityMap = constructEntityMap allDefs - body :: Q Exp - body = - case defs of - [] -> [|return ()|] - _ -> do - defsName <- newName "defs" - defsStmt <- do - defs' <- mapM (liftAndFixKeys entityMap) defs - let defsExp = ListE defs' - return $ LetS [ValD (VarP defsName) (NormalB defsExp) []] - stmts <- mapM (toStmt $ VarE defsName) defs - return (DoE $ defsStmt : stmts) - toStmt :: Exp -> EntityDef -> Q Stmt - toStmt defsExp ed = do - u <- liftAndFixKeys entityMap ed - m <- [|migrate|] - return $ NoBindS $ m `AppE` defsExp `AppE` u - -liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp -liftAndFixKeys entityMap EntityDef{..} = - [|EntityDef - entityHaskell - entityDB - $(liftAndFixKey entityMap entityId) - entityAttrs - $(ListE <$> mapM (liftAndFixKey entityMap) entityFields) - entityUniques - entityForeigns - entityDerives - entityExtra - entitySum - entityComments - |] - -liftAndFixKey :: EntityMap -> FieldDef -> Q Exp -liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef fc mcomments fg) = - [|FieldDef a b c $(sqlTyp') e f (fieldRef') fc mcomments fg|] - where - (fieldRef', sqlTyp') = - fromMaybe (fieldRef, lift sqlTyp) $ - case fieldRef of - ForeignRef refName _ft -> do - ent <- M.lookup refName entityMap - case fieldReference $ entityId ent of - fr@(ForeignRef _ ft) -> - Just (fr, lift $ SqlTypeExp ft) - _ -> - Nothing - _ -> - Nothing - -deriving instance Lift EntityDef - -deriving instance Lift FieldDef - -deriving instance Lift FieldAttr - -deriving instance Lift UniqueDef - -deriving instance Lift CompositeDef - -deriving instance Lift ForeignDef - --- | --- --- @since 2.8.3.0 -deriving instance Lift FieldCascade - --- | --- --- @since 2.8.3.0 -deriving instance Lift CascadeAction - -deriving instance Lift HaskellName -deriving instance Lift DBName -deriving instance Lift FieldType - -deriving instance Lift PersistFilter - -deriving instance Lift PersistUpdate - -deriving instance Lift SqlType - --- Ent --- fieldName FieldType --- --- forall . typ ~ FieldType => EntFieldName --- --- EntFieldName = FieldDef .... -mkField :: MkPersistSettings -> EntityDef -> FieldDef -> Q (Con, Clause) -mkField mps et cd = do - let con = ForallC - [] - [mkEqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing] - $ NormalC name [] - bod <- lift cd - let cla = normalClause - [ConP name []] - bod - return (con, cla) - where - name = filterConName mps et cd - -maybeNullable :: FieldDef -> Bool -maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr - -filterConName :: MkPersistSettings - -> EntityDef - -> FieldDef - -> Name -filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) - -filterConName' :: MkPersistSettings - -> HaskellName -- ^ table - -> HaskellName -- ^ field - -> Name -filterConName' mps entity field = mkName $ unpack name - where - name - | field == HaskellName "Id" = entityName ++ fieldName - | mpsPrefixFields mps = modifiedName - | otherwise = fieldName - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unHaskellName entity - fieldName = upperFirst $ unHaskellName field - -ftToType :: FieldType -> Type -ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t --- This type is generated from the Quasi-Quoter. --- Adding this special case avoids users needing to import Data.Int -ftToType (FTTypeCon (Just "Data.Int") "Int64") = ConT ''Int64 -ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t] -ftToType (FTApp x y) = ftToType x `AppT` ftToType y -ftToType (FTList x) = ListT `AppT` ftToType x - -infixr 5 ++ -(++) :: Text -> Text -> Text -(++) = append - -mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec] -mkJSON _ def | ("json" `notElem` entityAttrs def) = return [] -mkJSON mps def = do - requireExtensions [[FlexibleInstances]] - pureE <- [|pure|] - apE' <- [|(<*>)|] - packE <- [|pack|] - dotEqualE <- [|(.=)|] - dotColonE <- [|(.:)|] - dotColonQE <- [|(.:?)|] - objectE <- [|object|] - obj <- newName "obj" - mzeroE <- [|mzero|] - - xs <- mapM (newName . unpack . unHaskellNameForJSON . fieldHaskell) - $ entityFields def - - let conName = mkName $ unpack $ unHaskellName $ entityHaskell def - typ = genericDataType mps (entityHaskell def) backendT - toJSONI = typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] - toJSON' = FunD 'toJSON $ return $ normalClause - [ConP conName $ map VarP xs] - (objectE `AppE` ListE pairs) - pairs = zipWith toPair (entityFields def) xs - toPair f x = InfixE - (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f))) - dotEqualE - (Just $ VarE x) - fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] - parseJSON' = FunD 'parseJSON - [ normalClause [ConP 'Object [VarP obj]] - (foldl' - (\x y -> InfixE (Just x) apE' (Just y)) - (pureE `AppE` ConE conName) - pulls - ) - , normalClause [WildP] mzeroE - ] - pulls = map toPull $ entityFields def - toPull f = InfixE - (Just $ VarE obj) - (if maybeNullable f then dotColonQE else dotColonE) - (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell 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 = foldl AppT (ConT cla) tys - -mkEqualP :: Type -> Type -> Pred -mkEqualP tleft tright = 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 - --- entityUpdates :: EntityDef -> [(HaskellName, FieldType, IsNullable, PersistUpdate)] --- entityUpdates = --- concatMap go . entityFields --- where --- go FieldDef {..} = map (\a -> (fieldHaskell, fieldType, nullable fieldAttrs, a)) [minBound..maxBound] - --- mkToUpdate :: String -> [(String, PersistUpdate)] -> Q Dec --- mkToUpdate name pairs = do --- pairs' <- mapM go pairs --- return $ FunD (mkName name) $ degen pairs' --- where --- go (constr, pu) = do --- pu' <- lift pu --- return $ normalClause [RecP (mkName constr) []] pu' - - --- mkToFieldName :: String -> [(String, String)] -> Dec --- mkToFieldName func pairs = --- FunD (mkName func) $ degen $ map go pairs --- where --- go (constr, name) = --- normalClause [RecP (mkName constr) []] (LitE $ StringL name) - --- mkToValue :: String -> [String] -> Dec --- mkToValue func = FunD (mkName func) . degen . map go --- where --- go constr = --- let x = mkName "x" --- in normalClause [ConP (mkName constr) [VarP x]] --- (VarE 'toPersistValue `AppE` VarE x) - --- | 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 = map pure - [ DerivingStrategies - , GeneralizedNewtypeDeriving - , StandaloneDeriving - , UndecidableInstances - , MultiParamTypeClasses - ] - -mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec] -mkSymbolToFieldInstances mps ed = do - fmap join $ forM (entityFields ed) $ \fieldDef -> do - let fieldNameT = - litT $ strTyLit $ T.unpack $ unHaskellName $ fieldHaskell fieldDef - :: Q Type - nameG = mkName $ unpack $ unHaskellName (entityHaskell ed) ++ "Generic" - - recordNameT - | mpsGeneric mps = - conT nameG `appT` varT backendName - | otherwise = - conT $ mkName $ T.unpack $ unHaskellName $ entityHaskell ed - fieldTypeT = - maybeIdType mps fieldDef Nothing Nothing - entityFieldConstr = - conE $ filterConName mps ed fieldDef - :: Q Exp - [d| - instance SymbolToField $(fieldNameT) $(recordNameT) $(pure 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" (map show extensions) - , "\n\nPlease enable the extensions by copy/pasting these lines into the top of your file:\n\n" - , List.intercalate "\n" (map extensionToPragma extensions) - ] - - where - extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,7 @@ +# Begone! + +This package was absorbed into `persistent` with the 2.12.0.1 release. + ## persistent-template Provides Template Haskell helpers for persistent. For more information, see diff --git a/bench/Main.hs b/bench/Main.hs deleted file mode 100644 --- a/bench/Main.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Main (main) where - -import Control.DeepSeq -import Control.DeepSeq.Generics -import Criterion.Main -import Data.Text (Text) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import Database.Persist.Quasi -import Database.Persist.TH -import Models - -main :: IO () -main = defaultMain - [ bgroup "mkPersist" - [ bench "From File" $ nfIO $ mkPersist' $(persistFileWith lowerCaseSettings "bench/models-slowly") - -- , bgroup "Non-Null Fields" - -- [ bgroup "Increasing model count" - -- [ bench "1x10" $ nfIO $ mkPersist' $( parseReferencesQ (mkModels 10 10)) - -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10)) - -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 100 10)) - -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 1000 10)) - -- ] - -- , bgroup "Increasing field count" - -- [ bench "10x1" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1)) - -- , bench "10x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 10)) - -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 100)) - -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkModels 10 1000)) - -- ] - -- ] - -- , bgroup "Nullable" - -- [ bgroup "Increasing model count" - -- [ bench "20x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 20 10)) - -- , bench "40x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 40 10)) - -- , bench "60x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 60 10)) - -- , bench "80x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 80 10)) - -- , bench "100x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 100 10)) - -- -- , bench "1000x10" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 1000 10)) - -- ] - -- , bgroup "Increasing field count" - -- [ bench "10x20" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 20)) - -- , bench "10x40" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 40)) - -- , bench "10x60" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 60)) - -- , bench "10x80" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 80)) - -- , bench "10x100" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 100)) - -- -- , bench "10x1000" $ nfIO $ mkPersist' $(parseReferencesQ (mkNullableModels 10 1000)) - -- ] - -- ] - ] - ] - --- Orphan instances for NFData Template Haskell types -instance NFData Overlap where - rnf = genericRnf - -instance NFData AnnTarget where - rnf = genericRnf -instance NFData RuleBndr where - rnf = genericRnf - -instance NFData Role where - rnf = genericRnf - -instance NFData Phases where - rnf = genericRnf - -instance NFData InjectivityAnn where - rnf = genericRnf - -instance NFData FamilyResultSig where - rnf = genericRnf - -instance NFData RuleMatch where - rnf = genericRnf - -instance NFData TypeFamilyHead where - rnf = genericRnf - -instance NFData TySynEqn where - rnf = genericRnf - -instance NFData Inline where - rnf = genericRnf - -instance NFData Pragma where - rnf = genericRnf - -instance NFData FixityDirection where - rnf = genericRnf - -instance NFData Safety where - rnf = genericRnf - -instance NFData Fixity where - rnf = genericRnf - -instance NFData Callconv where - rnf = genericRnf - -instance NFData Foreign where - rnf = genericRnf - -instance NFData SourceStrictness where - rnf = genericRnf - -instance NFData SourceUnpackedness where - rnf = genericRnf - -instance NFData FunDep where - rnf = genericRnf - -instance NFData Bang where - rnf = genericRnf - -#if MIN_VERSION_template_haskell(2,12,0) -instance NFData PatSynDir where - rnf = genericRnf - -instance NFData PatSynArgs where - rnf = genericRnf - -instance NFData DerivStrategy where - rnf = genericRnf - -instance NFData DerivClause where - rnf = genericRnf -#endif - -instance NFData Con where - rnf = genericRnf - -instance NFData Range where - rnf = genericRnf - -instance NFData Clause where - rnf = genericRnf - -instance NFData PkgName where - rnf = genericRnf - -instance NFData Dec where - rnf = genericRnf - -instance NFData Stmt where - rnf = genericRnf - -instance NFData TyLit where - rnf = genericRnf - -instance NFData NameSpace where - rnf = genericRnf - -instance NFData Body where - rnf = genericRnf - -instance NFData Guard where - rnf = genericRnf - -instance NFData Match where - rnf = genericRnf - -instance NFData ModName where - rnf = genericRnf - -instance NFData Pat where - rnf = genericRnf - -instance NFData TyVarBndr where - rnf = genericRnf - -instance NFData NameFlavour where - rnf = genericRnf - -instance NFData Type where - rnf = genericRnf - -instance NFData Exp where - rnf = genericRnf - -instance NFData Lit where - rnf = genericRnf - -instance NFData OccName where - rnf = genericRnf - -instance NFData Name where - rnf = genericRnf diff --git a/bench/Models.hs b/bench/Models.hs deleted file mode 100644 --- a/bench/Models.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Models where - -import Data.Monoid -import Language.Haskell.TH -import qualified Data.Text as Text - -import Database.Persist.Quasi -import Database.Persist.TH -import Database.Persist.Sql - -mkPersist' :: [EntityDef] -> IO [Dec] -mkPersist' = runQ . mkPersist sqlSettings - -parseReferences' :: String -> IO Exp -parseReferences' = runQ . parseReferencesQ - -parseReferencesQ :: String -> Q Exp -parseReferencesQ = parseReferences lowerCaseSettings . Text.pack - --- | # of models, # of fields -mkModels :: Int -> Int -> String -mkModels = mkModelsWithFieldModifier id - -mkNullableModels :: Int -> Int -> String -mkNullableModels = mkModelsWithFieldModifier maybeFields - -mkModelsWithFieldModifier :: (String -> String) -> Int -> Int -> String -mkModelsWithFieldModifier k i f = - unlines . fmap unlines . take i . map mkModel . zip [0..] . cycle $ - [ "Model" - , "Foobar" - , "User" - , "King" - , "Queen" - , "Dog" - , "Cat" - ] - where - mkModel :: (Int, String) -> [String] - mkModel (i', m) = - (m <> show i') : indent 4 (map k (mkFields f)) - -indent :: Int -> [String] -> [String] -indent i = map (replicate i ' ' ++) - -mkFields :: Int -> [String] -mkFields i = take i $ map mkField $ zip [0..] $ cycle - [ "Bool" - , "Int" - , "String" - , "Double" - , "Text" - ] - where - mkField :: (Int, String) -> String - mkField (i', typ) = "field" <> show i' <> "\t\t" <> typ - -maybeFields :: String -> String -maybeFields = (++ " Maybe") diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 2.9.1.0 +version: 2.12.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -12,66 +12,14 @@ build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues -extra-source-files: test/main.hs ChangeLog.md README.md +extra-source-files: ChangeLog.md README.md library build-depends: base >= 4.10 && < 5 - , persistent >= 2.11 && < 3 - , aeson >= 1.0 && < 1.6 - , bytestring >= 0.10 - , containers - , http-api-data >= 0.3.7 - , monad-control >= 1.0 && < 1.1 - , monad-logger - , path-pieces - , template-haskell >= 2.11 - , text >= 1.2 - , th-lift-instances >= 0.1.14 && < 0.2 - , transformers >= 0.5 && < 0.6 - , unordered-containers - exposed-modules: Database.Persist.TH + exposed-modules: ghc-options: -Wall default-language: Haskell2010 -test-suite test - type: exitcode-stdio-1.0 - main-is: main.hs - hs-source-dirs: test - other-modules: - TemplateTestImports - , SharedPrimaryKeyTest - , SharedPrimaryKeyTestImported - , OverloadedLabelTest - - ghc-options: -Wall - - build-depends: base >= 4.10 && < 5 - , persistent - , persistent-template - , aeson - , bytestring - , hspec >= 2.4 - , QuickCheck - , text - default-language: Haskell2010 - source-repository head type: git location: git://github.com/yesodweb/persistent.git - -benchmark persistent-th-bench - ghc-options: -O2 - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: bench - build-depends: base - , persistent - , persistent-template - , criterion - , deepseq - , deepseq-generics - , file-embed - , text - , template-haskell - other-modules: Models - default-language: Haskell2010 diff --git a/test/OverloadedLabelTest.hs b/test/OverloadedLabelTest.hs deleted file mode 100644 --- a/test/OverloadedLabelTest.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module OverloadedLabelTest where - -import TemplateTestImports - -mkPersist sqlSettings [persistUpperCase| - -User - name String - age Int - -Dog - userId UserId - name String - age Int - -Organization - name String - -|] - -spec :: Spec -spec = describe "OverloadedLabels" $ do - it "works for monomorphic labels" $ do - let UserName = #name - OrganizationName = #name - DogName = #name - - compiles - - it "works for polymorphic labels" $ do - let name :: _ => EntityField rec a - name = #name - - UserName = name - OrganizationName = name - DogName = name - - compiles - -compiles :: Expectation -compiles = True `shouldBe` True diff --git a/test/SharedPrimaryKeyTest.hs b/test/SharedPrimaryKeyTest.hs deleted file mode 100644 --- a/test/SharedPrimaryKeyTest.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TypeApplications, DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DataKinds, FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} - -module SharedPrimaryKeyTest where - -import TemplateTestImports - -import Data.Proxy -import Test.Hspec -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util -import Database.Persist.TH - -share [ mkPersist sqlSettings ] [persistLowerCase| - -User - name String - --- TODO: uncomment this out https://github.com/yesodweb/persistent/issues/1149 --- Profile --- Id UserId --- email String - -Profile - Id (Key User) - email String - -|] - -spec :: Spec -spec = describe "Shared Primary Keys" $ do - - describe "PersistFieldSql" $ do - it "should match underlying key" $ do - sqlType (Proxy @UserId) - `shouldBe` - sqlType (Proxy @ProfileId) - - describe "entityId FieldDef" $ do - it "should match underlying primary key" $ do - let getSqlType :: PersistEntity a => Proxy a -> SqlType - getSqlType = - fieldSqlType . entityId . entityDef - getSqlType (Proxy @User) - `shouldBe` - getSqlType (Proxy @Profile) diff --git a/test/SharedPrimaryKeyTestImported.hs b/test/SharedPrimaryKeyTestImported.hs deleted file mode 100644 --- a/test/SharedPrimaryKeyTestImported.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE TypeApplications, DeriveGeneric #-} -{-# LANGUAGE DataKinds, ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} - -module SharedPrimaryKeyTestImported where - -import TemplateTestImports - -import Data.Proxy -import Test.Hspec -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util -import Database.Persist.TH - -import SharedPrimaryKeyTest (User, UserId) - -share [ mkPersist sqlSettings ] [persistLowerCase| - -Profile - Id UserId - email String - -|] - --- This test is very similar to the one in SharedPrimaryKeyTest, but it is --- able to use 'UserId' directly, since the type is imported from another --- module. -spec :: Spec -spec = describe "Shared Primary Keys Imported" $ do - - describe "PersistFieldSql" $ do - it "should match underlying key" $ do - sqlType (Proxy @UserId) - `shouldBe` - sqlType (Proxy @ProfileId) - - describe "entityId FieldDef" $ do - it "should match underlying primary key" $ do - let getSqlType :: PersistEntity a => Proxy a -> SqlType - getSqlType = - fieldSqlType . entityId . entityDef - getSqlType (Proxy @User) - `shouldBe` - getSqlType (Proxy @Profile) diff --git a/test/TemplateTestImports.hs b/test/TemplateTestImports.hs deleted file mode 100644 --- a/test/TemplateTestImports.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module TemplateTestImports - ( module TemplateTestImports - , module X - ) where - -import Data.Aeson.TH -import Test.QuickCheck - -import Test.Hspec as X -import Database.Persist.Sql as X -import Database.Persist.TH as X - -data Foo = Bar | Baz - deriving (Show, Eq) - -deriveJSON defaultOptions ''Foo - -derivePersistFieldJSON "Foo" - -instance Arbitrary Foo where - arbitrary = elements [Bar, Baz] diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# language DataKinds #-} - --- DeriveAnyClass is not actually used by persistent-template --- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving --- This was fixed by using DerivingStrategies to specify newtype deriving should be used. --- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled. --- See https://github.com/yesodweb/persistent/issues/578 -{-# LANGUAGE DeriveAnyClass #-} -module Main - ( - -- avoid unused ident warnings - module Main - ) where - -import Data.Int -import Data.Proxy -import Control.Applicative (Const (..)) -import Data.Aeson -import Data.ByteString.Lazy.Char8 () -import Data.Functor.Identity (Identity (..)) -import Data.Text (Text, pack) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen (Gen) -import GHC.Generics (Generic) -import qualified Data.List as List -import Data.Coerce - -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util -import Database.Persist.TH -import TemplateTestImports - -import qualified SharedPrimaryKeyTest -import qualified SharedPrimaryKeyTestImported -import qualified OverloadedLabelTest - -share [mkPersist sqlSettings { mpsGeneric = False, mpsDeriveInstances = [''Generic] }, mkDeleteCascade sqlSettings { mpsGeneric = False }] [persistUpperCase| - -Person json - name Text - age Int Maybe - foo Foo - address Address - deriving Show Eq - -HasSimpleCascadeRef - person PersonId OnDeleteCascade - deriving Show Eq - -Address json - street Text - city Text - zip Int Maybe - deriving Show Eq -NoJson - foo Text - deriving Show Eq -|] - -mkPersist sqlSettings [persistLowerCase| -HasPrimaryDef - userId Int - name String - Primary userId - -HasMultipleColPrimaryDef - foobar Int - barbaz String - Primary foobar barbaz - -HasIdDef - Id Int - name String - -HasDefaultId - name String - -HasCustomSqlId - Id String sql=my_id - name String - -SharedPrimaryKey - Id (Key HasDefaultId) - name String - -SharedPrimaryKeyWithCascade - Id (Key HasDefaultId) OnDeleteCascade - name String - -SharedPrimaryKeyWithCascadeAndCustomName - Id (Key HasDefaultId) OnDeleteCascade sql=my_id - name String -|] - -share [mkPersist sqlSettings { mpsGeneric = False, mpsGenerateLenses = True }] [persistLowerCase| -Lperson json - name Text - age Int Maybe - address Laddress - deriving Show Eq -Laddress json - street Text - city Text - zip Int Maybe - deriving Show Eq -CustomPrimaryKey - anInt Int - Primary anInt -|] - -arbitraryT :: Gen Text -arbitraryT = pack <$> arbitrary - -instance Arbitrary Person where - arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary Address where - arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary - -main :: IO () -main = hspec $ do - OverloadedLabelTest.spec - SharedPrimaryKeyTest.spec - SharedPrimaryKeyTestImported.spec - describe "HasDefaultId" $ do - let FieldDef{..} = - entityId (entityDef (Proxy @HasDefaultId)) - it "should have usual db name" $ do - fieldDB `shouldBe` DBName "id" - it "should have usual haskell name" $ do - fieldHaskell `shouldBe` HaskellName "Id" - it "should have correct underlying sql type" $ do - fieldSqlType `shouldBe` SqlInt64 - it "persistfieldsql should be right" $ do - sqlType (Proxy @HasDefaultIdId) `shouldBe` SqlInt64 - it "should have correct haskell type" $ do - fieldType `shouldBe` FTTypeCon Nothing "HasDefaultIdId" - - describe "HasCustomSqlId" $ do - let FieldDef{..} = - entityId (entityDef (Proxy @HasCustomSqlId)) - it "should have custom db name" $ do - fieldDB `shouldBe` DBName "my_id" - it "should have usual haskell name" $ do - fieldHaskell `shouldBe` HaskellName "id" - it "should have correct underlying sql type" $ do - fieldSqlType `shouldBe` SqlString - it "should have correct haskell type" $ do - fieldType `shouldBe` FTTypeCon Nothing "String" - describe "HasIdDef" $ do - let FieldDef{..} = - entityId (entityDef (Proxy @HasIdDef)) - it "should have usual db name" $ do - fieldDB `shouldBe` DBName "id" - it "should have usual haskell name" $ do - fieldHaskell `shouldBe` HaskellName "id" - it "should have correct underlying sql type" $ do - fieldSqlType `shouldBe` SqlInt64 - it "should have correct haskell type" $ do - fieldType `shouldBe` FTTypeCon Nothing "Int" - - describe "SharedPrimaryKey" $ do - let sharedDef = entityDef (Proxy @SharedPrimaryKey) - FieldDef{..} = - entityId sharedDef - it "should have usual db name" $ do - fieldDB `shouldBe` DBName "id" - it "should have usual haskell name" $ do - fieldHaskell `shouldBe` HaskellName "id" - it "should have correct underlying sql type" $ do - fieldSqlType `shouldBe` SqlInt64 - it "should have correct haskell type" $ do - fieldType `shouldBe` FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") - it "should have correct sql type from PersistFieldSql" $ do - sqlType (Proxy @SharedPrimaryKeyId) - `shouldBe` - SqlInt64 - it "should have same sqlType as underlying record" $ do - sqlType (Proxy @SharedPrimaryKeyId) - `shouldBe` - sqlType (Proxy @HasDefaultIdId) - it "should be a coercible newtype" $ do - coerce @Int64 3 - `shouldBe` - SharedPrimaryKeyKey (toSqlKey 3) - - it "is a newtype" $ do - pkNewtype sqlSettings sharedDef - `shouldBe` - True - - describe "SharedPrimaryKeyWithCascade" $ do - let FieldDef{..} = - entityId (entityDef (Proxy @SharedPrimaryKeyWithCascade)) - it "should have usual db name" $ do - fieldDB `shouldBe` DBName "id" - it "should have usual haskell name" $ do - fieldHaskell `shouldBe` HaskellName "id" - it "should have correct underlying sql type" $ do - fieldSqlType `shouldBe` SqlInt64 - it "should have correct haskell type" $ do - fieldType - `shouldBe` - FTApp (FTTypeCon Nothing "Key") (FTTypeCon Nothing "HasDefaultId") - it "should have cascade in field def" $ do - fieldCascade `shouldBe` noCascade { fcOnDelete = Just Cascade } - - describe "OnCascadeDelete" $ do - let subject :: FieldDef - Just subject = - List.find ((HaskellName "person" ==) . fieldHaskell) - $ entityFields - $ simpleCascadeDef - simpleCascadeDef = - entityDef (Proxy :: Proxy HasSimpleCascadeRef) - expected = - FieldCascade - { fcOnDelete = Just Cascade - , fcOnUpdate = Nothing - } - describe "entityDef" $ do - it "works" $ do - simpleCascadeDef - `shouldBe` - EntityDef - { entityHaskell = HaskellName "HasSimpleCascadeRef" - , entityDB = DBName "HasSimpleCascadeRef" - , entityId = - FieldDef - { fieldHaskell = HaskellName "Id" - , fieldDB = DBName "id" - , fieldType = FTTypeCon Nothing "HasSimpleCascadeRefId" - , fieldSqlType = SqlInt64 - , fieldReference = - ForeignRef (HaskellName "HasSimpleCascadeRef") (FTTypeCon (Just "Data.Int") "Int64") - , fieldAttrs = [] - , fieldStrict = True - , fieldComments = Nothing - , fieldCascade = noCascade - , fieldGenerated = Nothing - } - , entityAttrs = [] - , entityFields = - [ FieldDef - { fieldHaskell = HaskellName "person" - , fieldDB = DBName "person" - , fieldType = FTTypeCon Nothing "PersonId" - , fieldSqlType = SqlInt64 - , fieldAttrs = [] - , fieldStrict = True - , fieldReference = - ForeignRef - (HaskellName "Person") - (FTTypeCon (Just "Data.Int") "Int64") - , fieldCascade = - FieldCascade { fcOnUpdate = Nothing, fcOnDelete = Just Cascade } - , fieldComments = Nothing - , fieldGenerated = Nothing - } - ] - , entityUniques = [] - , entityForeigns = [] - , entityDerives = ["Show", "Eq"] - , entityExtra = mempty - , entitySum = False - , entityComments = Nothing - } - it "has the cascade on the field def" $ do - fieldCascade subject `shouldBe` expected - it "doesn't have any extras" $ do - entityExtra simpleCascadeDef - `shouldBe` - mempty - - describe "hasNaturalKey" $ do - let subject :: PersistEntity a => Proxy a -> Bool - subject p = hasNaturalKey (entityDef p) - it "is True for Primary keyword" $ do - subject (Proxy @HasPrimaryDef) - `shouldBe` - True - it "is True for multiple Primary columns " $ do - subject (Proxy @HasMultipleColPrimaryDef) - `shouldBe` - True - it "is False for Id keyword" $ do - subject (Proxy @HasIdDef) - `shouldBe` - False - it "is False for unspecified/default id" $ do - subject (Proxy @HasDefaultId) - `shouldBe` - False - describe "hasCompositePrimaryKey" $ do - let subject :: PersistEntity a => Proxy a -> Bool - subject p = hasCompositePrimaryKey (entityDef p) - it "is False for Primary with single column" $ do - subject (Proxy @HasPrimaryDef) - `shouldBe` - False - it "is True for multiple Primary columns " $ do - subject (Proxy @HasMultipleColPrimaryDef) - `shouldBe` - True - it "is False for Id keyword" $ do - subject (Proxy @HasIdDef) - `shouldBe` - False - it "is False for unspecified/default id" $ do - subject (Proxy @HasDefaultId) - `shouldBe` - False - - describe "JSON serialization" $ do - prop "to/from is idempotent" $ \person -> - decode (encode person) == Just (person :: Person) - it "decode" $ - decode "{\"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just - (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing) - describe "JSON serialization for Entity" $ do - let key = PersonKey 0 - prop "to/from is idempotent" $ \person -> - decode (encode (Entity key person)) == Just (Entity key (person :: Person)) - it "decode" $ - decode "{\"id\": 0, \"name\":\"Michael\",\"age\":27,\"foo\":\"Bar\",\"address\":{\"street\":\"Narkis\",\"city\":\"Maalot\"}}" `shouldBe` Just - (Entity key (Person "Michael" (Just 27) Bar $ Address "Narkis" "Maalot" Nothing)) - it "lens operations" $ do - let street1 = "street1" - city1 = "city1" - city2 = "city2" - zip1 = Just 12345 - address1 = Laddress street1 city1 zip1 - address2 = Laddress street1 city2 zip1 - name1 = "name1" - age1 = Just 27 - person1 = Lperson name1 age1 address1 - person2 = Lperson name1 age1 address2 - (person1 ^. lpersonAddress) `shouldBe` address1 - (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1 - (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2 - describe "Derived Show/Read instances" $ do - -- This tests confirms https://github.com/yesodweb/persistent/issues/1104 remains fixed - it "includes the name of the newtype when showing/reading a Key, i.e. uses the stock strategy when deriving Show/Read" $ do - show (PersonKey 0) `shouldBe` "PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 0}}" - read (show (PersonKey 0)) `shouldBe` PersonKey 0 - - show (CustomPrimaryKeyKey 0) `shouldBe` "CustomPrimaryKeyKey {unCustomPrimaryKeyKey = 0}" - read (show (CustomPrimaryKeyKey 0)) `shouldBe` CustomPrimaryKeyKey 0 - -(&) :: a -> (a -> b) -> b -x & f = f x - -(^.) :: s - -> ((a -> Const a b) -> (s -> Const a t)) - -> a -x ^. lens = getConst $ lens Const x - -(.~) :: ((a -> Identity b) -> (s -> Identity t)) - -> b - -> s - -> t -lens .~ val = runIdentity . lens (\_ -> Identity val)