Hello community,
here is the log from the commit of package ghc-persistent-template for
openSUSE:Factory checked in at 2020-11-12 22:45:13
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-persistent-template (Old)
and /work/SRC/openSUSE:Factory/.ghc-persistent-template.new.24930 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent-template"
Thu Nov 12 22:45:13 2020 rev:27 rq:847878 version:2.9.1.0
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-persistent-template/ghc-persistent-template.changes
2020-09-27 11:49:00.839994159 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-persistent-template.new.24930/ghc-persistent-template.changes
2020-11-12 22:45:16.906510702 +0100
@@ -1,0 +2,56 @@
+Sat Nov 7 16:50:20 UTC 2020 - [email protected]
+
+- Update persistent-template to version 2.9.1.0.
+ ## 2.9.1.0
+
+ * [#1145](https://github.com/yesodweb/persistent/pull/1148)
+ * Fix a bug where the `SqlType` for a shared primary key was being
+ incorrectly set to `SqlString` instead of whatever the target primary
key
+ sql type was.
+ * [#1151](https://github.com/yesodweb/persistent/pull/1151)
+ * Automatically generate `SymbolToField` instances for datatypes,
allowing
+ `OverloadedLabels` to be used with the `EntityField` type.
+
+ ## 2.9
+
+ * Always use the "stock" strategy when deriving Show/Read for keys
[#1106](https://github.com/yesodweb/persistent/pull/1106)
+ * This fixes a regression from 2.8.0, which started using the `newtype`
strategy when deriving `Show`/`Read` for keys
+ * In practice, this means that from 2.8.0–2.8.3.1, for the following
schema:
+
+ ```
+ Person
+ name Text
+ CustomPrimary
+ anInt Int
+ Primary anInt
+ name Text
+ ```
+
+ `PersonKey 1` would show as `"SqlBackendKey {unSqlBackendKey = 1}"`
+ and `CustomPrimaryKey 1` would show as `"1"`
+
+ This was generally poor for debugging and logging, since all tables
keys would print the same. For Persistent < 2.8.0 and > 2.8.3.1, they instead
will show as:
+
+ `"PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}"`
+ and `"CustomPrimaryKey {unCustomPrimaryKey = 1}"`
+
+ This could be a breaking change if you have used `Show` on a key, wrote
that string into some persistent storage like a database, and are trying to
`Read` it back again later.
+
+ ## 2.8.3.1
+
+ * Allow aeson 1.5. [#1085](https://github.com/yesodweb/persistent/pull/1085)
+
+ ## 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)
+
+-------------------------------------------------------------------
+Sat Nov 7 15:34:48 UTC 2020 - [email protected]
+
+- Update persistent-template to version 2.8.2.3 revision 2.
+ Upstream has revised the Cabal build instructions on Hackage.
+
+-------------------------------------------------------------------
Old:
----
persistent-template-2.8.2.3.tar.gz
persistent-template.cabal
New:
----
persistent-template-2.9.1.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-persistent-template.spec ++++++
--- /var/tmp/diff_new_pack.RuoWbA/_old 2020-11-12 22:45:17.938511779 +0100
+++ /var/tmp/diff_new_pack.RuoWbA/_new 2020-11-12 22:45:17.942511783 +0100
@@ -19,13 +19,12 @@
%global pkg_name persistent-template
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 2.8.2.3
+Version: 2.9.1.0
Release: 0
Summary: Type-safe, non-relational, multi-backend persistence
License: MIT
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-aeson-devel
BuildRequires: ghc-bytestring-devel
@@ -63,7 +62,6 @@
%prep
%autosetup -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ persistent-template-2.8.2.3.tar.gz -> persistent-template-2.9.1.0.tar.gz
++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.8.2.3/ChangeLog.md
new/persistent-template-2.9.1.0/ChangeLog.md
--- old/persistent-template-2.8.2.3/ChangeLog.md 2020-02-08
02:16:15.000000000 +0100
+++ new/persistent-template-2.9.1.0/ChangeLog.md 2020-11-04
19:48:32.000000000 +0100
@@ -1,5 +1,51 @@
## Unreleased changes
+## 2.9.1.0
+
+* [#1145](https://github.com/yesodweb/persistent/pull/1148)
+ * Fix a bug where the `SqlType` for a shared primary key was being
+ incorrectly set to `SqlString` instead of whatever the target primary key
+ sql type was.
+* [#1151](https://github.com/yesodweb/persistent/pull/1151)
+ * Automatically generate `SymbolToField` instances for datatypes, allowing
+ `OverloadedLabels` to be used with the `EntityField` type.
+
+## 2.9
+
+* Always use the "stock" strategy when deriving Show/Read for keys
[#1106](https://github.com/yesodweb/persistent/pull/1106)
+ * This fixes a regression from 2.8.0, which started using the `newtype`
strategy when deriving `Show`/`Read` for keys
+ * In practice, this means that from 2.8.0–2.8.3.1, for the following
schema:
+
+ ```
+ Person
+ name Text
+ CustomPrimary
+ anInt Int
+ Primary anInt
+ name Text
+ ```
+
+ `PersonKey 1` would show as `"SqlBackendKey {unSqlBackendKey = 1}"`
+ and `CustomPrimaryKey 1` would show as `"1"`
+
+ This was generally poor for debugging and logging, since all tables
keys would print the same. For Persistent < 2.8.0 and > 2.8.3.1, they instead
will show as:
+
+ `"PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}"`
+ and `"CustomPrimaryKey {unCustomPrimaryKey = 1}"`
+
+ This could be a breaking change if you have used `Show` on a key, wrote
that string into some persistent storage like a database, and are trying to
`Read` it back again later.
+
+## 2.8.3.1
+
+* Allow aeson 1.5. [#1085](https://github.com/yesodweb/persistent/pull/1085)
+
+## 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.8.2.3/Database/Persist/TH.hs
new/persistent-template-2.9.1.0/Database/Persist/TH.hs
--- old/persistent-template-2.8.2.3/Database/Persist/TH.hs 2020-02-08
02:16:15.000000000 +0100
+++ new/persistent-template-2.9.1.0/Database/Persist/TH.hs 2020-11-04
19:28:13.000000000 +0100
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -11,6 +12,8 @@
{-# 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 +31,8 @@
, mpsBackend
, mpsGeneric
, mpsPrefixFields
+ , mpsFieldLabelModifier
+ , mpsConstraintLabelModifier
, mpsEntityJSON
, mpsGenerateLenses
, mpsDeriveInstances
@@ -50,6 +55,7 @@
, fieldError
, AtLeastOneUniqueKey(..)
, OnlyOneUniqueKey(..)
+ , pkNewtype
) where
-- Development Tip: See persistent-template/README.md for advice on seeing
generated Template Haskell code
@@ -58,13 +64,16 @@
import Prelude hiding ((++), take, concat, splitAt, exp)
import Data.Either
-import Control.Monad (forM, mzero, filterM, guard, unless)
+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)
@@ -75,7 +84,7 @@
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,
stripPrefix, stripSuffix)
+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
@@ -84,7 +93,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 (appT, varT, conT, varE, varP, conE, litT,
strTyLit)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Web.PathPieces (PathPiece(..))
@@ -267,18 +276,30 @@
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|]
+ [|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) =
@@ -286,19 +307,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
@@ -312,14 +329,29 @@
constructEntityMap =
M.fromList . fmap (\ent -> (entityHaskell ent, ent))
-data FTTypeConDescr = FTKeyCon deriving Show
+data FTTypeConDescr = FTKeyCon
+ deriving Show
-mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr)
EmbedEntityDef
-mEmbedded _ (FTTypeCon Just{} _) = Left Nothing
-mEmbedded ents (FTTypeCon Nothing n) =
- let name = HaskellName n
- in maybe (Left Nothing) Right $ M.lookup name ents
-mEmbedded ents (FTList x) = mEmbedded ents x
+-- | 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
@@ -336,13 +368,17 @@
case mEmbedded allEntities (fieldType field) of
Left _ ->
case stripId $ fieldType field of
- Nothing -> NoReference
+ 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")
+ 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
@@ -351,7 +387,8 @@
else case fieldType field of
FTList _ -> SelfReference
_ -> error $ unpack $ unHaskellName entName
<> ": a self reference must be a Maybe"
- existing -> existing
+ existing ->
+ existing
}
mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef ->
EntityDefSqlTypeExp
@@ -362,38 +399,45 @@
maybe
(defaultSqlTypeExp field)
(SqlType' . SqlOther)
- (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs
field)
+ (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
+ 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
@@ -401,12 +445,17 @@
-- 'EntityDef's. Works well with the persist quasi-quoter.
mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkPersist mps ents' = do
- requireExtensions [[TypeFamilies], [GADTs, ExistentialQuantification]]
+ 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
- return $ mconcat [x, y, z, uniqueKeyInstances]
+ symbolToFieldInstances <- fmap mconcat $ mapM (mkSymbolToFieldInstances
mps) ents
+ return $ mconcat [x, y, z, uniqueKeyInstances, symbolToFieldInstances]
where
ents = map fixEntityDef ents'
entityMap = constructEntityMap ents
@@ -417,8 +466,8 @@
fixEntityDef ed =
ed { entityFields = filter keepField $ entityFields ed }
where
- keepField fd = "MigrationOnly" `notElem` fieldAttrs fd &&
- "SafeToRemove" `notElem` fieldAttrs fd
+ keepField fd = FieldAttrMigrationOnly `notElem` fieldAttrs fd &&
+ FieldAttrSafeToRemove `notElem` fieldAttrs fd
-- | Settings to be passed to the 'mkPersist' function.
data MkPersistSettings = MkPersistSettings
@@ -434,14 +483,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 +540,8 @@
{ mpsBackend = t
, mpsGeneric = False
, mpsPrefixFields = True
+ , mpsFieldLabelModifier = (++)
+ , mpsConstraintLabelModifier = (++)
, mpsEntityJSON = Just EntityJSON
{ entityToJSON = 'entityIdToJSON
, entityFromJSON = 'entityIdFromJSON
@@ -487,9 +556,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 +608,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 +636,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 =
@@ -578,17 +652,14 @@
(AppT (ConT ''Unique) (genericDataType mps (entityHaskell t) backendT))
Nothing
(map (mkUnique mps t) $ entityUniques t)
- (derivClause $ entityUniques t)
+ []
#else
DataInstD [] ''Unique
[genericDataType mps (entityHaskell t) backendT]
Nothing
(map (mkUnique mps t) $ entityUniques t)
- (derivClause $ entityUniques t)
+ []
#endif
- where
- derivClause [] = []
- derivClause _ = [DerivClause Nothing [ConT ''Show]]
mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con
mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =
@@ -840,16 +911,24 @@
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)
- cxti <- mapM conT i
let kd = if useNewtype
- then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing
dec [DerivClause (Just NewtypeStrategy) cxti]
- else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing
[dec] [DerivClause (Just StockStrategy) cxti]
+ then NewtypeInstD [] Nothing (AppT (ConT k) recordType) Nothing
dec deriveClauses
+ else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing
[dec] deriveClauses
#else
- cxti <- mapM conT i
let kd = if useNewtype
- then NewtypeInstD [] k [recordType] Nothing dec [DerivClause
(Just NewtypeStrategy) cxti]
- else DataInstD [] k [recordType] Nothing [dec] [DerivClause
(Just StockStrategy) cxti]
+ then NewtypeInstD [] k [recordType] Nothing dec deriveClauses
+ else DataInstD [] k [recordType] Nothing [dec] deriveClauses
#endif
return (kd, instDecs)
where
@@ -886,8 +965,9 @@
instances <- do
alwaysInstances <-
- [d|deriving newtype instance Show (BackendKey $(pure backendT)) =>
Show (Key $(pure recordType))
- deriving newtype instance Read (BackendKey $(pure backendT)) =>
Read (Key $(pure recordType))
+ -- 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))
@@ -942,6 +1022,9 @@
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
@@ -1062,11 +1145,11 @@
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
- let primaryField = entityId t
- fields <- mapM (mkField mps t) $ primaryField : entityFields t
toFieldNames <- mkToFieldNames $ entityUniques t
(keyTypeDec, keyInstanceDecs) <- mkKeyTypeDec mps t
@@ -1085,6 +1168,30 @@
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`
@@ -1095,6 +1202,7 @@
, keyTypeDec
, keyToValues'
, keyFromValues'
+ , keyFromRecordM'
, FunD 'entityDef [normalClause [WildP] t']
, tpf
, FunD 'fromPersistValues fpv
@@ -1267,7 +1375,8 @@
]
mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q
[Dec]
-mkForeignKeysComposite mps t ForeignDef {..} = do
+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
@@ -1275,8 +1384,12 @@
let tablename = mkName $ unpack $ entityText t
recordName <- newName "record"
- let fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName)
- `AppE` VarE recordName) foreignFields
+ 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]
@@ -1609,7 +1722,7 @@
[|EntityDef
entityHaskell
entityDB
- entityId
+ $(liftAndFixKey entityMap entityId)
entityAttrs
$(ListE <$> mapM (liftAndFixKey entityMap) entityFields)
entityUniques
@@ -1621,92 +1734,53 @@
|]
liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
-liftAndFixKey entityMap (FieldDef a b c sqlTyp e f fieldRef mcomments) =
- [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|]
+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 -> case M.lookup refName entityMap of
- Nothing -> Nothing
- Just ent ->
- case fieldReference $ entityId ent of
- fr@(ForeignRef _Name ft) -> Just (fr, lift $ SqlTypeExp ft)
- _ -> Nothing
- _ -> Nothing
-
-instance Lift EntityDef where
- lift EntityDef{..} =
- [|EntityDef
- entityHaskell
- entityDB
- entityId
- entityAttrs
- entityFields
- entityUniques
- entityForeigns
- entityDerives
- entityExtra
- entitySum
- entityComments
- |]
+ (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
-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 EntityDef
-instance Lift UniqueDef where
- lift (UniqueDef a b c d) = [|UniqueDef a b c d|]
+deriving instance Lift FieldDef
-instance Lift CompositeDef where
- lift (CompositeDef a b) = [|CompositeDef a b|]
+deriving instance Lift FieldAttr
-instance Lift ForeignDef where
- lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|]
-
-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|]
-
-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|]
-
-instance Lift PersistUpdate where
- lift Assign = [|Assign|]
- lift Add = [|Add|]
- lift Subtract = [|Subtract|]
- lift Multiply = [|Multiply|]
- lift Divide = [|Divide|]
- lift (BackendSpecificUpdate x) = [|BackendSpecificUpdate x|]
-
-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 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
@@ -1741,12 +1815,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
@@ -1879,8 +1956,33 @@
, 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:
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.8.2.3/README.md
new/persistent-template-2.9.1.0/README.md
--- old/persistent-template-2.8.2.3/README.md 2020-01-28 17:34:22.000000000
+0100
+++ new/persistent-template-2.9.1.0/README.md 2020-11-02 19:38:31.000000000
+0100
@@ -8,7 +8,7 @@
The TH.hs module contains code generators.
persistent-template uses `EntityDef`s that it gets from the quasi-quoter.
The quasi-quoter is in persistent Quasi.hs
-Similarly mant of the types come from the persistent library
+Similarly many of the types come from the persistent library
### Development tips
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/persistent-template-2.8.2.3/persistent-template.cabal
new/persistent-template-2.9.1.0/persistent-template.cabal
--- old/persistent-template-2.8.2.3/persistent-template.cabal 2020-02-08
02:16:15.000000000 +0100
+++ new/persistent-template-2.9.1.0/persistent-template.cabal 2020-11-03
19:55:48.000000000 +0100
@@ -1,5 +1,5 @@
name: persistent-template
-version: 2.8.2.3
+version: 2.9.1.0
license: MIT
license-file: LICENSE
author: Michael Snoyman <[email protected]>
@@ -16,8 +16,8 @@
library
build-depends: base >= 4.10 && < 5
- , persistent >= 2.10 && < 3
- , aeson >= 1.0 && < 1.5
+ , persistent >= 2.11 && < 3
+ , aeson >= 1.0 && < 1.6
, bytestring >= 0.10
, containers
, http-api-data >= 0.3.7
@@ -37,7 +37,12 @@
type: exitcode-stdio-1.0
main-is: main.hs
hs-source-dirs: test
- other-modules: TemplateTestImports
+ other-modules:
+ TemplateTestImports
+ , SharedPrimaryKeyTest
+ , SharedPrimaryKeyTestImported
+ , OverloadedLabelTest
+
ghc-options: -Wall
build-depends: base >= 4.10 && < 5
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/persistent-template-2.8.2.3/test/OverloadedLabelTest.hs
new/persistent-template-2.9.1.0/test/OverloadedLabelTest.hs
--- old/persistent-template-2.8.2.3/test/OverloadedLabelTest.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/persistent-template-2.9.1.0/test/OverloadedLabelTest.hs 2020-11-03
19:55:48.000000000 +0100
@@ -0,0 +1,56 @@
+{-# 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/persistent-template-2.8.2.3/test/SharedPrimaryKeyTest.hs
new/persistent-template-2.9.1.0/test/SharedPrimaryKeyTest.hs
--- old/persistent-template-2.8.2.3/test/SharedPrimaryKeyTest.hs
1970-01-01 01:00:00.000000000 +0100
+++ new/persistent-template-2.9.1.0/test/SharedPrimaryKeyTest.hs
2020-11-03 19:55:48.000000000 +0100
@@ -0,0 +1,57 @@
+{-# 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/persistent-template-2.8.2.3/test/SharedPrimaryKeyTestImported.hs
new/persistent-template-2.9.1.0/test/SharedPrimaryKeyTestImported.hs
--- old/persistent-template-2.8.2.3/test/SharedPrimaryKeyTestImported.hs
1970-01-01 01:00:00.000000000 +0100
+++ new/persistent-template-2.9.1.0/test/SharedPrimaryKeyTestImported.hs
2020-11-03 19:55:48.000000000 +0100
@@ -0,0 +1,54 @@
+{-# 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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/persistent-template-2.8.2.3/test/TemplateTestImports.hs
new/persistent-template-2.9.1.0/test/TemplateTestImports.hs
--- old/persistent-template-2.8.2.3/test/TemplateTestImports.hs 2019-05-07
01:24:32.000000000 +0200
+++ new/persistent-template-2.9.1.0/test/TemplateTestImports.hs 2020-11-03
19:55:48.000000000 +0100
@@ -1,10 +1,16 @@
{-# LANGUAGE TemplateHaskell #-}
-module TemplateTestImports where
+
+module TemplateTestImports
+ ( module TemplateTestImports
+ , module X
+ ) where
import Data.Aeson.TH
import Test.QuickCheck
-import Database.Persist.TH
+import Test.Hspec as X
+import Database.Persist.Sql as X
+import Database.Persist.TH as X
data Foo = Bar | Baz
deriving (Show, Eq)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.8.2.3/test/main.hs
new/persistent-template-2.9.1.0/test/main.hs
--- old/persistent-template-2.8.2.3/test/main.hs 2020-01-29
18:07:25.000000000 +0100
+++ new/persistent-template-2.9.1.0/test/main.hs 2020-11-04
19:28:13.000000000 +0100
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeApplications, DeriveGeneric, RecordWildCards #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -10,6 +10,7 @@
{-# 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
@@ -23,6 +24,8 @@
module Main
) where
+import Data.Int
+import Data.Proxy
import Control.Applicative (Const (..))
import Data.Aeson
import Data.ByteString.Lazy.Char8 ()
@@ -33,20 +36,32 @@
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
@@ -57,8 +72,40 @@
deriving Show Eq
|]
--- TODO: Derive Generic at the source site to get this unblocked.
-deriving instance Generic (BackendKey SqlBackend)
+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
@@ -71,6 +118,9 @@
city Text
zip Int Maybe
deriving Show Eq
+CustomPrimaryKey
+ anInt Int
+ Primary anInt
|]
arbitraryT :: Gen Text
@@ -78,11 +128,204 @@
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)
@@ -110,6 +353,14 @@
(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
_______________________________________________
openSUSE Commits mailing list -- [email protected]
To unsubscribe, email [email protected]
List Netiquette: https://en.opensuse.org/openSUSE:Mailing_list_netiquette
List Archives:
https://lists.opensuse.org/archives/list/[email protected]
