diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ ## Unreleased changes +## 2.8.3.0 + +* Add `Lift` instances for the cascade types. [#1060](https://github.com/yesodweb/persistent/pull/1060) +* Use `DeriveLift` to implement all `Lift` instances. Among other benefits, + this provides implementations of `liftTyped` on `template-haskell-2.16` (GHC + 8.10) or later. [#1064](https://github.com/yesodweb/persistent/pull/1064) + ## 2.8.2.3 * Require extensions in a more friendly manner. [#1030](https://github.com/yesodweb/persistent/pull/1030) diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -11,6 +11,7 @@ {-# 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 @@ -28,6 +29,8 @@ , mpsBackend , mpsGeneric , mpsPrefixFields + , mpsFieldLabelModifier + , mpsConstraintLabelModifier , mpsEntityJSON , mpsGenerateLenses , mpsDeriveInstances @@ -65,6 +68,9 @@ , 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) @@ -84,7 +90,7 @@ 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 (conT, varE) +import Language.Haskell.TH.Lib (conT, varE, varP) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.PathPieces (PathPiece(..)) @@ -267,18 +273,27 @@ 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 fieldComments|] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif instance Lift EntityDefSqlTypeExp where lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) = @@ -286,19 +301,15 @@ , entityId = $(lift $ FieldSqlTypeExp (entityId ent) sqlTypeExp) } |] +#if MIN_VERSION_template_haskell(2,16,0) + liftTyped = unsafeTExpCoerce . lift +#endif -instance Lift ReferenceDef where - lift NoReference = [|NoReference|] - lift (ForeignRef name ft) = [|ForeignRef name ft|] - lift (EmbedRef em) = [|EmbedRef em|] - lift (CompositeRef cdef) = [|CompositeRef cdef|] - lift SelfReference = [|SelfReference|] +deriving instance Lift ReferenceDef -instance Lift EmbedEntityDef where - lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|] +deriving instance Lift EmbedEntityDef -instance Lift EmbedFieldDef where - lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|] +deriving instance Lift EmbedFieldDef type EmbedEntityMap = M.Map HaskellName EmbedEntityDef @@ -434,14 +445,32 @@ -- 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 = 'keyValueEntityToJSON - -- , entityFromJSON = 'keyValueEntityFromJSON + -- { entityToJSON = 'entityIdToJSON + -- , entityFromJSON = 'entityIdFromJSON -- } -- @ , mpsGenerateLenses :: !Bool @@ -473,6 +502,8 @@ { mpsBackend = t , mpsGeneric = False , mpsPrefixFields = True + , mpsFieldLabelModifier = (++) + , mpsConstraintLabelModifier = (++) , mpsEntityJSON = Just EntityJSON { entityToJSON = 'entityIdToJSON , entityFromJSON = 'entityIdFromJSON @@ -487,9 +518,10 @@ recNameNoUnderscore :: MkPersistSettings -> HaskellName -> HaskellName -> Text recNameNoUnderscore mps dt f - | mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft + | mpsPrefixFields mps = lowerFirst $ modifier (unHaskellName dt) (upperFirst ft) | otherwise = lowerFirst ft where + modifier = mpsFieldLabelModifier mps ft = unHaskellName f recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text @@ -538,9 +570,12 @@ else Right n - stockClasses = Set.fromList . map mkName $ + 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, @@ -563,13 +598,14 @@ [(notStrict, maybeIdType mps fd Nothing Nothing)] sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat - [ if mpsPrefixFields mps - then unHaskellName $ entityHaskell t - else "" - , upperFirst $ unHaskellName fieldHaskell - , "Sum" - ] +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 = @@ -1085,6 +1121,31 @@ let instanceConstraint = if not (mpsGeneric mps) then [] else [mkClassP ''PersistStore [backendT]] + [keyFromRecordM'] <- + case entityPrimary t of + Just prim -> do + recordName <- newName "record" + let fields = map fieldHaskell (compositeFields prim) + 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` @@ -1095,6 +1156,7 @@ , keyTypeDec , keyToValues' , keyFromValues' + , keyFromRecordM' , FunD 'entityDef [normalClause [WildP] t'] , tpf , FunD 'fromPersistValues fpv @@ -1634,80 +1696,36 @@ _ -> Nothing _ -> Nothing -instance Lift EntityDef where - lift EntityDef{..} = - [|EntityDef - entityHaskell - entityDB - entityId - entityAttrs - entityFields - entityUniques - entityForeigns - entityDerives - entityExtra - entitySum - entityComments - |] +deriving instance Lift EntityDef -instance Lift FieldDef where - lift (FieldDef a b c d e f g h) = [|FieldDef a b c d e f g h|] +deriving instance Lift FieldDef -instance Lift UniqueDef where - lift (UniqueDef a b c d) = [|UniqueDef a b c d|] +deriving instance Lift UniqueDef -instance Lift CompositeDef where - lift (CompositeDef a b) = [|CompositeDef a b|] +deriving instance Lift CompositeDef -instance Lift ForeignDef where - lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|] +deriving instance Lift ForeignDef -instance Lift HaskellName where - lift (HaskellName t) = [|HaskellName t|] -instance Lift DBName where - lift (DBName t) = [|DBName t|] -instance Lift FieldType where - lift (FTTypeCon Nothing t) = [|FTTypeCon Nothing t|] - lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just x) t|] - lift (FTApp x y) = [|FTApp x y|] - lift (FTList x) = [|FTList x|] +-- | +-- +-- @since 2.8.3.0 +deriving instance Lift FieldCascade -instance Lift PersistFilter where - lift Eq = [|Eq|] - lift Ne = [|Ne|] - lift Gt = [|Gt|] - lift Lt = [|Lt|] - lift Ge = [|Ge|] - lift Le = [|Le|] - lift In = [|In|] - lift NotIn = [|NotIn|] - lift (BackendSpecificFilter x) = [|BackendSpecificFilter x|] +-- | +-- +-- @since 2.8.3.0 +deriving instance Lift CascadeAction -instance Lift PersistUpdate where - lift Assign = [|Assign|] - lift Add = [|Add|] - lift Subtract = [|Subtract|] - lift Multiply = [|Multiply|] - lift Divide = [|Divide|] - lift (BackendSpecificUpdate x) = [|BackendSpecificUpdate x|] +deriving instance Lift HaskellName +deriving instance Lift DBName +deriving instance Lift FieldType -instance Lift SqlType where - lift SqlString = [|SqlString|] - lift SqlInt32 = [|SqlInt32|] - lift SqlInt64 = [|SqlInt64|] - lift SqlReal = [|SqlReal|] - lift (SqlNumeric x y) = - [|SqlNumeric (fromInteger x') (fromInteger y')|] - where - x' = fromIntegral x :: Integer - y' = fromIntegral y :: Integer - lift SqlBool = [|SqlBool|] - lift SqlDay = [|SqlDay|] - lift SqlTime = [|SqlTime|] - lift SqlDayTime = [|SqlDayTime|] - lift SqlBlob = [|SqlBlob|] - lift (SqlOther a) = [|SqlOther a|] +deriving instance Lift PersistFilter +deriving instance Lift PersistUpdate + +deriving instance Lift SqlType + -- Ent -- fieldName FieldType -- @@ -1741,12 +1759,15 @@ -> HaskellName -- ^ table -> HaskellName -- ^ field -> Name -filterConName' mps entity field = mkName $ unpack $ concat - [ if mpsPrefixFields mps || field == HaskellName "Id" - then unHaskellName entity - else "" - , upperFirst $ unHaskellName field - ] +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 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.8.2.3 +version: 2.8.3.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -16,7 +16,7 @@ library build-depends: base >= 4.10 && < 5 - , persistent >= 2.10 && < 3 + , persistent >= 2.11 && < 3 , aeson >= 1.0 && < 1.5 , bytestring >= 0.10 , containers