Hello community,
here is the log from the commit of package ghc-persistent-template for
openSUSE:Factory checked in at 2019-12-27 13:56:16
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-persistent-template (Old)
and /work/SRC/openSUSE:Factory/.ghc-persistent-template.new.6675 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent-template"
Fri Dec 27 13:56:16 2019 rev:20 rq:759477 version:2.7.3
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-persistent-template/ghc-persistent-template.changes
2019-08-13 13:15:21.041504501 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-persistent-template.new.6675/ghc-persistent-template.changes
2019-12-27 13:56:18.640743603 +0100
@@ -1,0 +2,16 @@
+Fri Nov 8 16:14:27 UTC 2019 - Peter Simons <psim...@suse.com>
+
+- Drop obsolete group attributes.
+
+-------------------------------------------------------------------
+Tue Oct 29 07:32:27 UTC 2019 - psim...@suse.com
+
+- Update persistent-template to version 2.7.3.
+ ## Unreleased changes
+
+ ## 2.7.3
+
+ * Update module documentation for `Database.Persist.TH` to better describe
the purpose of the module
[#968](https://github.com/yesodweb/persistent/pull/968)
+ * Support template-haskell-2.15
[#959](https://github.com/yesodweb/persistent/pull/959)
+
+-------------------------------------------------------------------
Old:
----
persistent-template-2.7.2.tar.gz
New:
----
persistent-template-2.7.3.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-persistent-template.spec ++++++
--- /var/tmp/diff_new_pack.mGv4GN/_old 2019-12-27 13:56:19.108743829 +0100
+++ /var/tmp/diff_new_pack.mGv4GN/_new 2019-12-27 13:56:19.108743829 +0100
@@ -19,11 +19,10 @@
%global pkg_name persistent-template
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 2.7.2
+Version: 2.7.3
Release: 0
Summary: Type-safe, non-relational, multi-backend persistence
License: MIT
-Group: Development/Libraries/Haskell
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
BuildRequires: ghc-Cabal-devel
@@ -51,7 +50,6 @@
%package devel
Summary: Haskell %{pkg_name} library development files
-Group: Development/Libraries/Haskell
Requires: %{name} = %{version}-%{release}
Requires: ghc-compiler = %{ghc_version}
Requires(post): ghc-compiler = %{ghc_version}
++++++ persistent-template-2.7.2.tar.gz -> persistent-template-2.7.3.tar.gz
++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.7.2/ChangeLog.md
new/persistent-template-2.7.3/ChangeLog.md
--- old/persistent-template-2.7.2/ChangeLog.md 2019-07-17 15:42:19.000000000
+0200
+++ new/persistent-template-2.7.3/ChangeLog.md 2019-10-28 16:58:53.000000000
+0100
@@ -1,3 +1,10 @@
+## Unreleased changes
+
+## 2.7.3
+
+* Update module documentation for `Database.Persist.TH` to better describe the
purpose of the module [#968](https://github.com/yesodweb/persistent/pull/968)
+* Support template-haskell-2.15
[#959](https://github.com/yesodweb/persistent/pull/959)
+
## 2.7.2
* Expose the knot tying logic of `parseReferences` so that users can build
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.7.2/Database/Persist/TH.hs
new/persistent-template-2.7.3/Database/Persist/TH.hs
--- old/persistent-template-2.7.2/Database/Persist/TH.hs 2019-07-17
15:42:19.000000000 +0200
+++ new/persistent-template-2.7.3/Database/Persist/TH.hs 2019-10-28
16:58:53.000000000 +0100
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@@ -8,8 +9,8 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}
--- | This module provides utilities for creating backends. Regular users do not
--- need to use this module.
+-- | 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
@@ -53,6 +54,7 @@
, Value (Object), (.:), (.:?)
, eitherDecodeStrict'
)
+import qualified Data.ByteString as BS
import Data.Char (toLower, toUpper)
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
@@ -60,19 +62,17 @@
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.Monoid ((<>), mappend, mconcat)
import Data.Proxy (Proxy (Proxy))
import Data.Text (pack, Text, append, unpack, concat, uncons, cons,
stripPrefix, stripSuffix)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Encoding as TE
-import qualified Data.Text.IO as TIO
import GHC.Generics (Generic)
import GHC.TypeLits
import Language.Haskell.TH.Lib (conT, varE)
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
-import qualified System.IO as SIO
import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident))
import Web.PathPieces (PathPiece(..))
import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..))
@@ -86,8 +86,10 @@
-- <https://github.com/yesodweb/persistent/issues/412>
unHaskellNameForJSON :: HaskellName -> Text
unHaskellNameForJSON = fixTypeUnderscore . unHaskellName
- where fixTypeUnderscore "type" = "type_"
- fixTypeUnderscore name = name
+ 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).
@@ -155,17 +157,14 @@
persistManyFileWith :: PersistSettings -> [FilePath] -> Q Exp
persistManyFileWith ps fps = do
mapM_ qAddDependentFile fps
- ss <- mapM getS 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
- where
- getS fp = do
- h <- qRunIO $ SIO.openFile fp SIO.ReadMode
- qRunIO $ SIO.hSetEncoding h SIO.utf8_bom
- s <- qRunIO $ TIO.hGetContents h
- return s
--- Takes a list of (potentially) independently defined entities and properly
+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.
--
@@ -182,48 +181,48 @@
noCycleEnts = map breakCycleEnt entsWithEmbeds
-- every EntityDef could reference each-other (as an EmbedRef)
-- let Haskell tie the knot
- embedEntityMap = M.fromList $ map (\ent -> (entityHaskell ent,
toEmbedEntityDef ent)) entsWithEmbeds
+ embedEntityMap = constructEmbedEntityMap entsWithEmbeds
entsWithEmbeds = map setEmbedEntity rawEnts
setEmbedEntity ent = ent
- { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap)
$ entityFields 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 }
+ let entName = entityHaskell entDef
+ in entDef { entityFields = map (breakCycleField entName) $
entityFields entDef }
- breakCycleField entName f@(FieldDef { fieldReference = EmbedRef em }) =
- f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
- breakCycleField _ f = f
+ breakCycleField entName f = case f of
+ FieldDef { fieldReference = EmbedRef em } ->
+ f { fieldReference = EmbedRef $ breakCycleEmbed [entName] em }
+ _ ->
+ f
breakCycleEmbed ancestors em =
- em { embeddedFields = map (breakCycleEmField $ emName : ancestors)
- (embeddedFields em)
+ em { embeddedFields = breakCycleEmField (emName : ancestors) <$>
embeddedFields em
}
- where
- emName = embeddedHaskell 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
+ 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 entMap) noCycleEnts
+ map (mkEntityDefSqlTypeExp embedEntityMap entityMap) noCycleEnts
where
(embedEntityMap, noCycleEnts) = embedEntityDefsMap $ parse ps s
- entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) noCycleEnts
-
+ entityMap = constructEntityMap noCycleEnts
stripId :: FieldType -> Maybe Text
stripId (FTTypeCon Nothing t) = stripSuffix "Id" t
@@ -237,21 +236,23 @@
-- 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
+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
+ where
+ typ = ftToType ftype
+ mtyp = ConT ''Proxy `AppT` typ
+ typedNothing = SigE (ConE 'Proxy) mtyp
+ st = VarE 'sqlType `AppE` typedNothing
data FieldsSqlTypeExp = FieldsSqlTypeExp [FieldDef] [SqlTypeExp]
@@ -260,9 +261,10 @@
lift $ zipWith FieldSqlTypeExp fields sqlTypeExps
data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp
+
instance Lift FieldSqlTypeExp where
- lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) =
- [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) fieldAttrs
fieldStrict fieldReference fieldComments|]
+ lift (FieldSqlTypeExp FieldDef{..} sqlTypeExp) =
+ [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp)
fieldAttrs fieldStrict fieldReference fieldComments|]
instance Lift EntityDefSqlTypeExp where
lift (EntityDefSqlTypeExp ent sqlTypeExp sqlTypeExps) =
@@ -276,7 +278,7 @@
lift (ForeignRef name ft) = [|ForeignRef name ft|]
lift (EmbedRef em) = [|EmbedRef em|]
lift (CompositeRef cdef) = [|CompositeRef cdef|]
- lift (SelfReference) = [|SelfReference|]
+ lift SelfReference = [|SelfReference|]
instance Lift EmbedEntityDef where
lift (EmbedEntityDef name fields) = [|EmbedEntityDef name fields|]
@@ -285,99 +287,114 @@
lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|]
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
+
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 (FTTypeCon Nothing n) =
+ let name = HaskellName n
+ in 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
+ -- 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
- `Data.Monoid.mappend` ": a self reference must be a
Maybe"
- existing@_ -> existing
+ { 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 entMap ent = EntityDefSqlTypeExp ent
- (getSqlType $ entityId ent)
- $ (map getSqlType $ entityFields ent)
- where
- getSqlType field = maybe
- (defaultSqlTypeExp field)
- (SqlType' . SqlOther)
- (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ fieldAttrs field)
-
+mkEntityDefSqlTypeExp emEntities entityMap ent =
+ EntityDefSqlTypeExp ent (getSqlType $ entityId ent) (map getSqlType $
entityFields ent)
+ where
+ getSqlType field =
+ maybe
+ (defaultSqlTypeExp field)
+ (SqlType' . SqlOther)
+ (listToMaybe $ mapMaybe (stripPrefix "sqltype=") $ 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 entMap 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
+ 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
x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents
- y <- fmap mconcat $ mapM (mkEntity entMap 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]
where
ents = map fixEntityDef ents'
- entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) ents
+ entityMap = constructEntityMap ents
-- | Implement special preprocessing on EntityDef as necessary for 'mkPersist'.
-- For example, strip out any fields marked as MigrationOnly.
@@ -428,8 +445,9 @@
}
-- | Create an @MkPersistSettings@ with default values.
-mkPersistSettings :: Type -- ^ Value for 'mpsBackend'
- -> MkPersistSettings
+mkPersistSettings
+ :: Type -- ^ Value for 'mpsBackend'
+ -> MkPersistSettings
mkPersistSettings t = MkPersistSettings
{ mpsBackend = t
, mpsGeneric = False
@@ -449,7 +467,8 @@
recNameNoUnderscore mps dt f
| mpsPrefixFields mps = lowerFirst (unHaskellName dt) ++ upperFirst ft
| otherwise = lowerFirst ft
- where ft = unHaskellName f
+ where
+ ft = unHaskellName f
recName :: MkPersistSettings -> HaskellName -> HaskellName -> Text
recName mps dt f =
@@ -518,11 +537,19 @@
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)
+ (derivClause $ entityUniques t)
+#else
DataInstD [] ''Unique
[genericDataType mps (entityHaskell t) backendT]
Nothing
(map (mkUnique mps t) $ entityUniques t)
(derivClause $ entityUniques t)
+#endif
where
derivClause [] = []
#if MIN_VERSION_template_haskell(2,12,0)
@@ -535,8 +562,8 @@
mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =
NormalC (mkName $ unpack constr) types
where
- types = map (go . flip lookup3 (entityFields t))
- $ map (unHaskellName . fst) fields
+ types =
+ map (go . flip lookup3 (entityFields t) . unHaskellName . fst) fields
force = "!force" `elem` attrs
@@ -757,8 +784,6 @@
]
$ 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])
@@ -781,7 +806,12 @@
bi <- backendKeyI
return (bi, allInstances)
-#if MIN_VERSION_template_haskell(2,12,0)
+#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 Nothing cxti]
+ else DataInstD [] Nothing (AppT (ConT k) recordType) Nothing
[dec] [DerivClause Nothing cxti]
+#elif MIN_VERSION_template_haskell(2,12,0)
cxti <- mapM conT i
let kd = if useNewtype
then NewtypeInstD [] k [recordType] Nothing dec [DerivClause
Nothing cxti]
@@ -877,7 +907,7 @@
keyIdName = mkName . unpack . keyIdText
keyIdText :: EntityDef -> Text
-keyIdText t = (unHaskellName $ entityHaskell t) `mappend` "Id"
+keyIdText t = unHaskellName (entityHaskell t) `mappend` "Id"
unKeyName :: EntityDef -> Name
unKeyName t = mkName $ "un" `mappend` keyString t
@@ -914,7 +944,7 @@
keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]
keyFields mps t = case entityPrimary t of
- Just pdef -> map primaryKeyVar $ (compositeFields pdef)
+ Just pdef -> map primaryKeyVar (compositeFields pdef)
Nothing -> if defaultIdType t
then [idKeyVar backendKeyType]
else [idKeyVar $ ftToType $ fieldType $ entityId t]
@@ -931,8 +961,7 @@
keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name
keyFieldName mps t fd
| pkNewtype mps t = unKeyName t
- | otherwise = mkName $ unpack
- $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)
+ | otherwise = mkName $ unpack $ lowerFirst (keyText t) `mappend`
unHaskellName (fieldHaskell fd)
mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec
mkKeyToValues mps t = do
@@ -956,8 +985,8 @@
mkKeyFromValues _mps t = do
clauses <- case entityPrimary t of
Nothing -> do
- e <- [|fmap $(return $ keyConE) . fromPersistValue . headNote|]
- return $ [normalClause [] e]
+ e <- [|fmap $(return keyConE) . fromPersistValue . headNote|]
+ return [normalClause [] e]
Just pdef ->
fromValues t "keyFromValues" keyConE (compositeFields pdef)
return $ FunD 'keyFromValues clauses
@@ -965,61 +994,61 @@
keyConE = keyConExp t
headNote :: [PersistValue] -> PersistValue
-headNote (x:[]) = x
-headNote xs = error $ "mkKeyFromValues: expected a list of one element, got: "
- `mappend` show xs
+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 ]
+ 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
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))
+ 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)
+ UInfixE exp applyE (fpv `AppE` VarE name)
mkPersistValue field =
- [|mapLeft (fieldError t field) . fromPersistValue|]
+ [|mapLeft (fieldError t field) . fromPersistValue|]
fieldError :: EntityDef -> FieldDef -> Text -> Text
fieldError entity field err = mconcat
- [ "Couldn't parse field `"
- , fieldName
- , "` from table `"
- , tableName
- , "`. "
- , err
- ]
+ [ "Couldn't parse field `"
+ , fieldName
+ , "` from table `"
+ , tableName
+ , "`. "
+ , err
+ ]
where
fieldName =
- unHaskellName (fieldHaskell field)
+ unHaskellName (fieldHaskell field)
tableName =
- unDBName (entityDB entity)
+ unDBName (entityDB entity)
mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec]
-mkEntity entMap mps t = do
- t' <- liftAndFixKeys entMap t
+mkEntity entityMap mps t = do
+ t' <- liftAndFixKeys entityMap t
let nameT = unHaskellName entName
let nameS = unpack nameT
let clazz = ConT ''PersistEntity `AppT` genDataType
@@ -1055,7 +1084,7 @@
dtd : mconcat fkc `mappend`
([ TySynD (keyIdName t) [] $
ConT ''Key `AppT` ConT (mkName nameS)
- , instanceD instanceConstraint clazz $
+ , instanceD instanceConstraint clazz
[ uniqueTypeDec mps t
, keyTypeDec
, keyToValues'
@@ -1066,6 +1095,15 @@
, 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
@@ -1075,12 +1113,21 @@
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
]
@@ -1149,7 +1196,7 @@
singleUniqueKey :: Q [Dec]
singleUniqueKey = do
- expr <- [e|\p -> head (persistUniqueKeys p)|]
+ expr <- [e| head . persistUniqueKeys|]
let impl = [FunD onlyUniquePName [Clause [] (NormalB expr) []]]
cxt <- withPersistStoreWriteCxt
pure [instanceD cxt onlyOneUniqueKeyClass impl]
@@ -1159,7 +1206,7 @@
atLeastOneKey :: Q [Dec]
atLeastOneKey = do
- expr <- [e|\p -> NEL.fromList (persistUniqueKeys p)|]
+ expr <- [e| NEL.fromList . persistUniqueKeys|]
let impl = [FunD requireUniquesPName [Clause [] (NormalB expr) []]]
cxt <- withPersistStoreWriteCxt
pure [instanceD cxt atLeastOneUniqueKeyClass impl]
@@ -1221,21 +1268,21 @@
mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q
[Dec]
mkForeignKeysComposite mps t ForeignDef {..} = 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 fldsE = map (\((foreignName, _),_) -> VarE (fieldName $ foreignName)
- `AppE` VarE recordName) 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]
+ 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 fldsE = map (\((foreignName, _),_) -> VarE (fieldName foreignName)
+ `AppE` VarE recordName) 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
@@ -1244,8 +1291,6 @@
maybeTyp may typ | may = ConT ''Maybe `AppT` typ
| otherwise = typ
-
-
-- | produce code similar to the following:
--
-- @
@@ -1286,10 +1331,10 @@
[ sqlTypeFunD ss
]
]
- where
- typ = genericDataType mps (entityHaskell e) backendT
- entFields = entityFields e
- columnNames = map (unpack . unHaskellName . fieldHaskell) entFields
+ where
+ typ = genericDataType mps (entityHaskell e) backendT
+ entFields = entityFields e
+ columnNames = map (unpack . unHaskellName . fieldHaskell) entFields
-- | Apply the given list of functions to the same @EntityDef@s.
--
@@ -1297,7 +1342,7 @@
--
-- >>> share [mkSave "myDefs", mkPersist sqlSettings] [persistLowerCase|...|]
share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]
-share fs x = fmap mconcat $ mapM ($ x) fs
+share fs x = mconcat <$> mapM ($ x) fs
-- | Save the @EntityDef@s passed in under the given name.
mkSave :: String -> [EntityDef] -> Q [Dec]
@@ -1532,9 +1577,9 @@
]
where
defs = filter isMigrated allDefs
- isMigrated def = not $ "no-migrate" `elem` entityAttrs def
+ isMigrated def = "no-migrate" `notElem` entityAttrs def
typ = ConT ''Migration
- entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) allDefs
+ entityMap = constructEntityMap allDefs
body :: Q Exp
body =
case defs of
@@ -1542,40 +1587,40 @@
_ -> do
defsName <- newName "defs"
defsStmt <- do
- defs' <- mapM (liftAndFixKeys entMap) defs
+ 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 entMap ed
+ u <- liftAndFixKeys entityMap ed
m <- [|migrate|]
return $ NoBindS $ m `AppE` defsExp `AppE` u
liftAndFixKeys :: EntityMap -> EntityDef -> Q Exp
-liftAndFixKeys entMap EntityDef{..} =
- [|EntityDef
- entityHaskell
- entityDB
- entityId
- entityAttrs
- $(ListE <$> mapM (liftAndFixKey entMap) entityFields)
- entityUniques
- entityForeigns
- entityDerives
- entityExtra
- entitySum
- entityComments
- |]
+liftAndFixKeys entityMap EntityDef{..} =
+ [|EntityDef
+ entityHaskell
+ entityDB
+ entityId
+ entityAttrs
+ $(ListE <$> mapM (liftAndFixKey entityMap) entityFields)
+ entityUniques
+ entityForeigns
+ entityDerives
+ entityExtra
+ entitySum
+ entityComments
+ |]
liftAndFixKey :: EntityMap -> FieldDef -> Q Exp
-liftAndFixKey entMap (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 mcomments) =
+ [|FieldDef a b c $(sqlTyp') e f fieldRef' mcomments|]
where
(fieldRef', sqlTyp') = fromMaybe (fieldRef, lift sqlTyp) $
case fieldRef of
- ForeignRef refName _ft -> case M.lookup refName entMap of
+ ForeignRef refName _ft -> case M.lookup refName entityMap of
Nothing -> Nothing
Just ent ->
case fieldReference $ entityId ent of
@@ -1598,12 +1643,16 @@
entitySum
entityComments
|]
+
instance Lift FieldDef where
lift (FieldDef a b c d e f g h) = [|FieldDef a b c d e f g h|]
+
instance Lift UniqueDef where
lift (UniqueDef a b c d) = [|UniqueDef a b c d|]
+
instance Lift CompositeDef where
lift (CompositeDef a b) = [|CompositeDef a b|]
+
instance Lift ForeignDef where
lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|]
@@ -1730,7 +1779,7 @@
(++) = append
mkJSON :: MkPersistSettings -> EntityDef -> Q [Dec]
-mkJSON _ def | not ("json" `elem` entityAttrs def) = return []
+mkJSON _ def | ("json" `notElem` entityAttrs def) = return []
mkJSON mps def = do
pureE <- [|pure|]
apE' <- [|(<*>)|]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/persistent-template-2.7.2/persistent-template.cabal
new/persistent-template-2.7.3/persistent-template.cabal
--- old/persistent-template-2.7.2/persistent-template.cabal 2019-07-17
15:42:19.000000000 +0200
+++ new/persistent-template-2.7.3/persistent-template.cabal 2019-10-28
16:58:53.000000000 +0100
@@ -1,5 +1,5 @@
name: persistent-template
-version: 2.7.2
+version: 2.7.3
license: MIT
license-file: LICENSE
author: Michael Snoyman <mich...@snoyman.com>
