persistent-template 2.8.2.3 → 2.8.3.0
raw patch · 3 files changed
+123/−95 lines, 3 filesdep ~persistentdep ~template-haskell
Dependency ranges changed: persistent, template-haskell
Files
- ChangeLog.md +7/−0
- Database/Persist/TH.hs +114/−93
- persistent-template.cabal +2/−2
ChangeLog.md view
@@ -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)
Database/Persist/TH.hs view
@@ -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
persistent-template.cabal view
@@ -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 <michael@snoyman.com>@@ -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