Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2021-04-26 16:39:35 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new.12324 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent" Mon Apr 26 16:39:35 2021 rev:26 rq:888409 version:2.12.1.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2021-04-10 15:28:21.686447916 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new.12324/ghc-persistent.changes 2021-04-26 16:40:33.966168365 +0200 @@ -1,0 +2,19 @@ +Thu Apr 22 08:38:42 UTC 2021 - psim...@suse.com + +- Update persistent to version 2.12.1.1. + Upstream has edited the change log file since the last release in + a non-trivial way, i.e. they did more than just add a new entry + at the top. You can review the file at: + http://hackage.haskell.org/package/persistent-2.12.1.1/src/ChangeLog.md + +------------------------------------------------------------------- +Thu Apr 8 20:12:52 UTC 2021 - psim...@suse.com + +- Update persistent to version 2.12.1.0. + ## 2.12.1.0 + + * [#1226](https://github.com/yesodweb/persistent/pull/1226) + * Expose the `filterClause` and `filterClauseWithValues` functions to support + the `upsertWhere` functionality in `persistent-postgresql`. + +------------------------------------------------------------------- Old: ---- persistent-2.12.0.2.tar.gz New: ---- persistent-2.12.1.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.QssqXm/_old 2021-04-26 16:40:34.482169213 +0200 +++ /var/tmp/diff_new_pack.QssqXm/_new 2021-04-26 16:40:34.482169213 +0200 @@ -19,7 +19,7 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.12.0.2 +Version: 2.12.1.1 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT ++++++ persistent-2.12.0.2.tar.gz -> persistent-2.12.1.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/ChangeLog.md new/persistent-2.12.1.1/ChangeLog.md --- old/persistent-2.12.0.2/ChangeLog.md 2021-04-01 18:42:09.000000000 +0200 +++ new/persistent-2.12.1.1/ChangeLog.md 2021-04-20 23:24:51.000000000 +0200 @@ -1,5 +1,20 @@ # Changelog for persistent +## 2.12.1.1 + +* [#1231](https://github.com/yesodweb/persistent/pull/1231) + * Simplify Line type in Quasi module, always use NonEmpty +* [#1229](https://github.com/yesodweb/persistent/pull/1229) + * The `#id` labels are now generated for entities. + +## 2.12.1.0 + +* [#1218](https://github.com/yesodweb/persistent/pull/1218) + * Refactoring name generating functions in TH +* [#1226](https://github.com/yesodweb/persistent/pull/1226) + * Expose the `filterClause` and `filterClauseWithValues` functions to support + the `upsertWhere` functionality in `persistent-postgresql`. + ## 2.12.0.2 * [#1123](https://github.com/yesodweb/persistent/pull/1223) @@ -22,10 +37,10 @@ * Added `makeCompatibleInstances` and `makeCompatibleKeyInstances`, TemplateHaskell invocations for auto-generating standalone derivations using `Compatible` and `DerivingVia`. * [#1207](https://github.com/yesodweb/persistent/pull/1207) * @codygman discovered a bug in [issue #1199](https://github.com/yesodweb/persistent/issues/1199) where postgres connections were being returned to the `Pool SqlBackend` in an inconsistent state. - @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. + @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug. Fortunately, this doesn't affect the public API, and can be a mere bug release. - * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. + * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`. * Renaming values in persistent-template [#1203](https://github.com/yesodweb/persistent/pull/1203) * [#1214](https://github.com/yesodweb/persistent/pull/1214): diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/Database/Persist/Class/PersistUnique.hs new/persistent-2.12.1.1/Database/Persist/Class/PersistUnique.hs --- old/persistent-2.12.0.2/Database/Persist/Class/PersistUnique.hs 2021-03-18 16:47:21.000000000 +0100 +++ new/persistent-2.12.1.1/Database/Persist/Class/PersistUnique.hs 2021-04-20 23:24:17.000000000 +0200 @@ -3,42 +3,42 @@ {-# LANGUAGE TypeOperators #-} module Database.Persist.Class.PersistUnique - ( PersistUniqueRead(..) - , PersistUniqueWrite(..) - , OnlyOneUniqueKey(..) - , onlyOneUniqueDef - , AtLeastOneUniqueKey(..) - , atLeastOneUniqueDef - , NoUniqueKeysError - , MultipleUniqueKeysError - , getByValue - , getByValueUniques - , insertBy - , insertUniqueEntity - , replaceUnique - , checkUnique - , checkUniqueUpdateable - , onlyUnique - , defaultUpsertBy - , defaultPutMany - , persistUniqueKeyValues - ) - where + ( PersistUniqueRead(..) + , PersistUniqueWrite(..) + , OnlyOneUniqueKey(..) + , onlyOneUniqueDef + , AtLeastOneUniqueKey(..) + , atLeastOneUniqueDef + , NoUniqueKeysError + , MultipleUniqueKeysError + , getByValue + , getByValueUniques + , insertBy + , insertUniqueEntity + , replaceUnique + , checkUnique + , checkUniqueUpdateable + , onlyUnique + , defaultUpsertBy + , defaultPutMany + , persistUniqueKeyValues + ) + where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Data.Function (on) -import Data.List ((\\), deleteFirstsBy) +import Data.List (deleteFirstsBy, (\\)) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe (catMaybes) import GHC.TypeLits (ErrorMessage(..)) -import Database.Persist.Types -import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity +import Database.Persist.Class.PersistStore +import Database.Persist.Types -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -419,10 +419,13 @@ -- > +----+-------+-----+ insertUniqueEntity - :: forall record backend m. (MonadIO m - ,PersistRecordBackend record backend - ,PersistUniqueWrite backend) - => record -> ReaderT backend m (Maybe (Entity record)) + :: forall record backend m + . ( MonadIO m + , PersistRecordBackend record backend + , PersistUniqueWrite backend + ) + => record + -> ReaderT backend m (Maybe (Entity record)) insertUniqueEntity datum = fmap (\key -> Entity key datum) `liftM` insertUnique datum diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/Database/Persist/Quasi.hs new/persistent-2.12.1.1/Database/Persist/Quasi.hs --- old/persistent-2.12.0.2/Database/Persist/Quasi.hs 2021-03-29 21:25:27.000000000 +0200 +++ new/persistent-2.12.1.1/Database/Persist/Quasi.hs 2021-04-20 23:24:19.000000000 +0200 @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -421,12 +421,11 @@ , nullable #if TEST , Token (..) - , Line' (..) + , Line (..) , preparse , parseLine , parseFieldType , associateLines - , skipEmpty , LinesWithComments(..) , splitExtras , takeColsEx @@ -435,15 +434,15 @@ import Prelude hiding (lines) -import Control.Applicative ( Alternative((<|>)) ) +import Control.Applicative (Alternative((<|>))) import Control.Arrow ((&&&)) -import Control.Monad (msum, mplus) -import Data.Char ( isLower, isSpace, isUpper, toLower ) +import Control.Monad (mplus, msum) +import Data.Char (isLower, isSpace, isUpper, toLower) import Data.List (find, foldl') -import qualified Data.List.NonEmpty as NEL import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (mapMaybe, fromMaybe, maybeToList, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) import Data.Monoid (mappend) #if !MIN_VERSION_base(4,11,0) -- This can be removed when GHC < 8.2.2 isn't supported anymore @@ -543,16 +542,9 @@ lns <- NEL.nonEmpty (T.lines txt) NEL.nonEmpty $ mapMaybe parseLine (NEL.toList lns) --- TODO: refactor to return (Line' NonEmpty), made possible by --- https://github.com/yesodweb/persistent/pull/1206 but left out --- in order to minimize the diff parseLine :: Text -> Maybe Line -parseLine txt = - case tokenize txt of - [] -> - Nothing - toks -> - pure $ Line (parseIndentationAmount txt) toks +parseLine txt = do + Line (parseIndentationAmount txt) <$> NEL.nonEmpty (tokenize txt) -- | A token used by the parser. data Token = Token Text -- ^ @Token tok@ is token @tok@ already unquoted. @@ -622,46 +614,28 @@ let (x, y) = T.break (`elem` ['\\','(',')']) t' in parens count y (front . (x:)) --- | A line. We don't care about spaces in the middle of the --- line. Also, we don't care about the amount of indentation. -data Line' f - = Line +-- | A line of parsed tokens +data Line = Line { lineIndent :: Int - , tokens :: f Token - } - -deriving instance Show (f Token) => Show (Line' f) -deriving instance Eq (f Token) => Eq (Line' f) - -mapLine :: (forall x. f x -> g x) -> Line' f -> Line' g -mapLine k (Line i t) = Line i (k t) - -traverseLine :: Functor t => (forall x. f x -> t (g x)) -> Line' f -> t (Line' g) -traverseLine k (Line i xs) = Line i <$> k xs + , tokens :: NonEmpty Token + } deriving (Eq, Show) -lineText :: Functor f => Line' f -> f Text +lineText :: Line -> NonEmpty Text lineText = fmap tokenText . tokens -type Line = Line' [] - -lowestIndent - :: Functor f - => Foldable f - => Functor g - => f (Line' g) - -> Int +lowestIndent :: NonEmpty Line -> Int lowestIndent = minimum . fmap lineIndent -- | Divide lines into blocks and make entity definitions. parseLines :: PersistSettings -> NonEmpty Line -> [EntityDef] parseLines ps = - fixForeignKeysAll . map mk . associateLines . skipEmpty + fixForeignKeysAll . map mk . associateLines where mk :: LinesWithComments -> UnboundEntityDef mk lwc = let ln :| rest = lwcLines lwc (name :| entAttribs) = lineText ln - in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs (map (mapLine NEL.toList) rest) + in setComments (lwcComments lwc) $ mkEntityDef ps name entAttribs rest isDocComment :: Token -> Maybe Text isDocComment tok = @@ -670,7 +644,7 @@ _ -> Nothing data LinesWithComments = LinesWithComments - { lwcLines :: NonEmpty (Line' NonEmpty) + { lwcLines :: NonEmpty Line , lwcComments :: [Text] } deriving (Eq, Show) @@ -680,24 +654,24 @@ appendLwc a b = LinesWithComments (foldr NEL.cons (lwcLines b) (lwcLines a)) (lwcComments a `mappend` lwcComments b) -newLine :: Line' NonEmpty -> LinesWithComments +newLine :: Line -> LinesWithComments newLine l = LinesWithComments (pure l) [] -firstLine :: LinesWithComments -> Line' NonEmpty +firstLine :: LinesWithComments -> Line firstLine = NEL.head . lwcLines -consLine :: Line' NonEmpty -> LinesWithComments -> LinesWithComments +consLine :: Line -> LinesWithComments -> LinesWithComments consLine l lwc = lwc { lwcLines = NEL.cons l (lwcLines lwc) } consComment :: Text -> LinesWithComments -> LinesWithComments consComment l lwc = lwc { lwcComments = l : lwcComments lwc } -associateLines :: [Line' NonEmpty] -> [LinesWithComments] +associateLines :: NonEmpty Line -> [LinesWithComments] associateLines lines = foldr combine [] $ foldr toLinesWithComments [] lines where - toLinesWithComments :: Line' NonEmpty -> [LinesWithComments] -> [LinesWithComments] + toLinesWithComments :: Line -> [LinesWithComments] -> [LinesWithComments] toLinesWithComments line linesWithComments = case linesWithComments of [] -> @@ -730,9 +704,6 @@ minimumIndentOf = lowestIndent . lwcLines -skipEmpty :: NonEmpty (Line' []) -> [Line' NonEmpty] -skipEmpty = mapMaybe (traverseLine NEL.nonEmpty) . NEL.toList - setComments :: [Text] -> UnboundEntityDef -> UnboundEntityDef setComments [] = id setComments comments = @@ -954,13 +925,14 @@ case lns of [] -> ([], M.empty) (line : rest) -> - case line of - Line indent [Token name] + case NEL.toList (tokens line) of + [Token name] | isCapitalizedText name -> - let (children, rest') = span ((> indent) . lineIndent) rest + let indent = lineIndent line + (children, rest') = span ((> indent) . lineIndent) rest (x, y) = splitExtras rest' - in (x, M.insert name (map lineText children) y) - Line _ ts -> + in (x, M.insert name (NEL.toList . lineText <$> children) y) + ts -> let (x, y) = splitExtras rest in (ts:x, y) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/Database/Persist/Sql/Orphan/PersistQuery.hs new/persistent-2.12.1.1/Database/Persist/Sql/Orphan/PersistQuery.hs --- old/persistent-2.12.0.2/Database/Persist/Sql/Orphan/PersistQuery.hs 2021-03-22 15:41:28.000000000 +0100 +++ new/persistent-2.12.1.1/Database/Persist/Sql/Orphan/PersistQuery.hs 2021-04-19 23:23:45.000000000 +0200 @@ -6,6 +6,10 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount + , filterClause + , filterClauseHelper + , filterClauseWithVals + , FilterTablePrefix (..) , decorateSQLWithLimitOffset ) where @@ -36,7 +40,7 @@ conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " , connEscapeTableName conn t @@ -59,7 +63,7 @@ conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t @@ -93,7 +97,7 @@ t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts ord conn = case map (orderClause False conn) orders of [] -> "" @@ -119,7 +123,7 @@ wher conn = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn @@ -183,7 +187,7 @@ let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts sql = mconcat [ "DELETE FROM " , connEscapeTableName conn t @@ -203,7 +207,7 @@ conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "UPDATE " , connEscapeTableName conn t @@ -217,26 +221,42 @@ where t = entityDef $ dummyFromFilts filts -fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> FieldNameDB +fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> FieldNameDB fieldName f = fieldDB $ persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing -getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +getFiltsValues :: forall val. (PersistEntity val) => SqlBackend -> [Filter val] -> [PersistValue] -getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo +getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo -filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> Bool -- ^ include WHERE? +-- | Used when determining how to prefix a column name in a @WHERE@ clause. +-- +-- @since 2.12.1.0 +data FilterTablePrefix + = PrefixTableName + -- ^ Prefix the column with the table name. This is useful if the column + -- name might be ambiguous. + -- + -- @since 2.12.1.0 + | PrefixExcluded + -- ^ Prefix the column name with the @EXCLUDED@ keyword. This is used with + -- the Postgresql backend when doing @ON CONFLICT DO UPDATE@ clauses - see + -- the documentation on @upsertWhere@ and @upsertManyWhere@. + -- + -- @since 2.12.1.0 + +filterClauseHelper :: (PersistEntity val) + => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED + -> Bool -- ^ include WHERE -> SqlBackend -> OrNull -> [Filter val] -> (Text, [PersistValue]) -filterClauseHelper includeTable includeWhere conn orNull filters = +filterClauseHelper tablePrefix includeWhere conn orNull filters = (if not (T.null sql) && includeWhere then " WHERE " <> sql else sql, vals) @@ -356,7 +376,9 @@ orNullSuffix = case orNull of - OrNullYes -> mconcat [" OR ", name, " IS NULL"] + OrNullYes -> mconcat [" OR " + , name + , " IS NULL"] OrNullNo -> "" isNull = PersistNull `elem` allVals @@ -364,10 +386,10 @@ allVals = filterValueToPersistValues value tn = connEscapeTableName conn $ entityDef $ dummyFromFilts [Filter field value pfilter] name = - (if includeTable - then ((tn <> ".") <>) - else id) - $ connEscapeFieldName conn (fieldName field) + case tablePrefix of + Just PrefixTableName -> ((tn <> ".") <>) $ connEscapeFieldName conn (fieldName field) + Just PrefixExcluded -> (("EXCLUDED.") <>) $ connEscapeFieldName conn (fieldName field) + _ -> id $ connEscapeFieldName conn (fieldName field) qmarks = case value of FilterValue{} -> "(?)" UnsafeValue{} -> "(?)" @@ -387,14 +409,30 @@ showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s -filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? +-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion +-- into a SQL query. +-- +-- @since 2.12.1.0 +filterClause :: (PersistEntity val) + => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion +-- into a SQL query, as well as the @['PersistValue']@ to properly fill in the +-- @?@ place holders. +-- +-- @since 2.12.1.0 +filterClauseWithVals :: (PersistEntity val) + => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED + -> SqlBackend + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseWithVals b c = filterClauseHelper b True c OrNullNo + +orderClause :: (PersistEntity val) => Bool -- ^ include the table name -> SqlBackend -> SelectOpt val @@ -410,7 +448,7 @@ tn = connEscapeTableName conn (entityDef $ dummyFromOrder o) - name :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) + name :: (PersistEntity record) => EntityField record typ -> Text name x = (if includeTable @@ -433,4 +471,4 @@ [ sql , lim , off - ] \ No newline at end of file + ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/Database/Persist/Sql/Util.hs new/persistent-2.12.1.1/Database/Persist/Sql/Util.hs --- old/persistent-2.12.0.2/Database/Persist/Sql/Util.hs 2021-03-22 15:41:28.000000000 +0100 +++ new/persistent-2.12.1.1/Database/Persist/Sql/Util.hs 2021-04-19 23:23:45.000000000 +0200 @@ -207,6 +207,7 @@ mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text mkUpdateText conn = mkUpdateText' (connEscapeFieldName conn) id +-- TODO: incorporate the table names into a sum type mkUpdateText' :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text mkUpdateText' escapeName refColumn x = case updateUpdate x of @@ -223,7 +224,7 @@ parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] --- | Make a list 'PersistValue' suitable for detabase inserts. Pairs nicely +-- | Make a list 'PersistValue' suitable for database inserts. Pairs nicely -- with the function 'mkInsertPlaceholders'. -- -- Does not include generated columns. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/Database/Persist/Sql.hs new/persistent-2.12.1.1/Database/Persist/Sql.hs --- old/persistent-2.12.0.2/Database/Persist/Sql.hs 2021-03-26 20:15:27.000000000 +0100 +++ new/persistent-2.12.1.1/Database/Persist/Sql.hs 2021-04-19 23:23:45.000000000 +0200 @@ -12,6 +12,9 @@ , rawSql , deleteWhereCount , updateWhereCount + , filterClause + , filterClauseWithVals + , FilterTablePrefix (..) , transactionSave , transactionSaveWithIsolation , transactionUndo @@ -27,13 +30,13 @@ import Control.Monad.Trans.Reader (ReaderT, ask) import Database.Persist -import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel (..)) import Database.Persist.Sql.Class -import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) -import Database.Persist.Sql.Raw -import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal +import Database.Persist.Sql.Migration +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) +import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal (IsolationLevel(..)) import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/Database/Persist/TH.hs new/persistent-2.12.1.1/Database/Persist/TH.hs --- old/persistent-2.12.0.2/Database/Persist/TH.hs 2021-03-29 21:25:27.000000000 +0200 +++ new/persistent-2.12.1.1/Database/Persist/TH.hs 2021-04-20 21:32:51.000000000 +0200 @@ -93,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 (appT, varT, conT, varE, varP, conE, litT, strTyLit) +import Language.Haskell.TH.Lib (appT, varT, conK, conT, varE, varP, conE, litT, strTyLit) import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.PathPieces (PathPiece(..)) @@ -104,16 +104,6 @@ import Database.Persist.Sql (Migration, PersistFieldSql, SqlBackend, migrate, sqlType) import Database.Persist.Quasi --- | This special-cases "type_" and strips out its underscore. When --- used for JSON serialization and deserialization, it works around --- <https://github.com/yesodweb/persistent/issues/412> -unFieldNameHSForJSON :: FieldNameHS -> Text -unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS - where - fixTypeUnderscore = \case - "type" -> "type_" - name -> name - -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist). persistWith :: PersistSettings -> QuasiQuoter @@ -256,7 +246,6 @@ ForeignRef ref _ -> Just ref _ -> Nothing - -- fieldSqlType at parse time can be an Exp -- This helps delay setting fieldSqlType until lift time data EntityDefSqlTypeExp @@ -584,9 +573,7 @@ dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec dataTypeDec mps entDef = do - let entityInstances = map (mkName . unpack) $ entityDerives entDef - additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps - names = entityInstances <> additionalInstances + let names = mkEntityDefDeriveNames mps entDef let (stocks, anyclasses) = partitionEithers (map stratFor names) let stockDerives = do @@ -614,37 +601,27 @@ ] <> [''Eq, ''Ord, ''Show, ''Read, ''Bounded, ''Enum, ''Ix, ''Generic, ''Data, ''Typeable ] ) - mkCol x fd@FieldDef {..} = - (mkName $ unpack $ recNameF mps x fieldHaskell, - if fieldStrict then isStrict else notStrict, - maybeIdType mps fd Nothing Nothing - ) + (nameFinal, paramsFinal) - | mpsGeneric mps = (nameG, [PlainTV backend]) - | otherwise = (name, []) - nameG = mkName $ unpack $ unEntityNameHS (entityHaskell entDef) ++ "Generic" - name = mkName $ unpack $ unEntityNameHS $ entityHaskell entDef - cols = map (mkCol $ entityHaskell entDef) $ entityFields entDef - backend = backendName + | mpsGeneric mps = (mkEntityDefGenericName entDef, [PlainTV backendName]) + | otherwise = (mkEntityDefName entDef, []) + + cols :: [VarBangType] + cols = do + fieldDef <- entityFields entDef + let recordName = fieldDefToRecordName mps entDef fieldDef + strictness = if fieldStrict fieldDef then isStrict else notStrict + fieldIdType = maybeIdType mps fieldDef Nothing Nothing + in pure (recordName, strictness, fieldIdType) constrs | entitySum entDef = map sumCon $ entityFields entDef - | otherwise = [RecC name cols] + | otherwise = [RecC (mkEntityDefName entDef) cols] sumCon fieldDef = NormalC (sumConstrName mps entDef fieldDef) [(notStrict, maybeIdType mps fieldDef Nothing Nothing)] -sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -sumConstrName mps entDef FieldDef {..} = mkName $ unpack name - where - name - | mpsPrefixFields mps = modifiedName ++ "Sum" - | otherwise = fieldName ++ "Sum" - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unEntityNameHS $ entityHaskell entDef - fieldName = upperFirst $ unFieldNameHS fieldHaskell - uniqueTypeDec :: MkPersistSettings -> EntityDef -> Dec uniqueTypeDec mps entDef = #if MIN_VERSION_template_haskell(2,15,0) @@ -662,8 +639,8 @@ #endif mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con -mkUnique mps entDef (UniqueDef (ConstraintNameHS constr) _ fields attrs) = - NormalC (mkName $ unpack constr) types +mkUnique mps entDef (UniqueDef constr _ fields attrs) = + NormalC (mkConstraintName constr) types where types = map (go . flip lookup3 (entityFields entDef) . unFieldNameHS . fst) fields @@ -676,7 +653,7 @@ lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) lookup3 s [] = - error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ constr + error $ unpack $ "Column not found: " ++ s ++ " in unique " ++ unConstraintNameHS constr lookup3 x (fd@FieldDef {..}:rest) | x == unFieldNameHS fieldHaskell = (fd, nullable fieldAttrs) | otherwise = lookup3 x rest @@ -708,13 +685,14 @@ | mpsGeneric mps = backendT | otherwise = mpsBackend mps -genericDataType :: MkPersistSettings - -> EntityNameHS - -> Type -- ^ backend - -> Type -genericDataType mps (EntityNameHS typ') backend - | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend - | otherwise = ConT $ mkName $ unpack typ' +genericDataType + :: MkPersistSettings + -> EntityNameHS + -> Type -- ^ backend + -> Type +genericDataType mps name backend + | mpsGeneric mps = ConT (mkEntityNameHSGenericName name) `AppT` backend + | otherwise = ConT $ mkEntityNameHSName name idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type idType mps fieldDef mbackend = @@ -731,8 +709,8 @@ in [normalClause [WildP] err] degen x = x -mkToPersistFields :: MkPersistSettings -> String -> EntityDef -> Q Dec -mkToPersistFields mps constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do +mkToPersistFields :: MkPersistSettings -> EntityDef -> Q Dec +mkToPersistFields mps ed@EntityDef { entitySum = isSum, entityFields = fields } = do clauses <- if isSum then sequence $ zipWith goSum fields [1..] @@ -742,7 +720,8 @@ go :: Q Clause go = do xs <- sequence $ replicate fieldCount $ newName "x" - let pat = ConP (mkName constr) $ map VarP xs + let name = mkEntityDefName ed + pat = ConP name $ map VarP xs sp <- [|SomePersistField|] let bod = ListE $ map (AppE sp . VarE) xs return $ normalClause [pat] bod @@ -776,7 +755,7 @@ names' <- lift names return $ normalClause - [RecP (mkName $ unpack $ unConstraintNameHS constr) []] + [RecP (mkConstraintName constr) []] names' mkUniqueToValues :: [UniqueDef] -> Q Dec @@ -787,7 +766,7 @@ go :: UniqueDef -> Q Clause go (UniqueDef constr _ names _) = do xs <- mapM (const $ newName "x") names - let pat = ConP (mkName $ unpack $ unConstraintNameHS constr) $ map VarP xs + let pat = ConP (mkConstraintName constr) $ map VarP xs tpv <- [|toPersistValue|] let bod = ListE $ map (AppE tpv . VarE) xs return $ normalClause [pat] bod @@ -804,8 +783,7 @@ mkFromPersistValues _ entDef@(EntityDef { entitySum = False }) = fromValues entDef "fromPersistValues" entE $ entityFields entDef where - entE = ConE $ mkName $ unpack entName - entName = unEntityNameHS $ entityHaskell entDef + entE = entityDefConE entDef mkFromPersistValues mps entDef@(EntityDef { entitySum = True }) = do nothing <- [|Left ("Invalid fromPersistValues input: sum type with all nulls. Entity: " `mappend` entName)|] @@ -854,11 +832,11 @@ then return $ idClause : map (toSumClause lens' keyVar valName xName) (entityFields entDef) else return $ idClause : map (toClause lens' getVal dot keyVar valName xName) (entityFields entDef) where - toClause lens' getVal dot keyVar valName xName f = normalClause - [ConP (filterConName mps entDef f) []] + toClause lens' getVal dot keyVar valName xName fieldDef = normalClause + [ConP (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where - fieldName = mkName $ unpack $ recNameF mps (entityHaskell entDef) (fieldHaskell f) + fieldName = fieldDefToRecordName mps entDef fieldDef getter = InfixE (Just $ VarE fieldName) dot (Just getVal) setter = LamE [ ConP 'Entity [VarP keyVar, VarP valName] @@ -989,39 +967,6 @@ supplement :: [Name] -> [Name] supplement names = names <> (filter (`notElem` names) $ mpsDeriveInstances mps) -keyIdName :: EntityDef -> Name -keyIdName = mkName . unpack . keyIdText - -keyIdText :: EntityDef -> Text -keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id" - -unKeyName :: EntityDef -> Name -unKeyName entDef = mkName $ "un" `mappend` keyString entDef - -unKeyExp :: EntityDef -> Exp -unKeyExp = VarE . unKeyName - -backendT :: Type -backendT = VarT backendName - -backendName :: Name -backendName = mkName "backend" - -keyConName :: EntityDef -> Name -keyConName entDef = mkName $ resolveConflict $ keyString entDef - where - resolveConflict kn = if conflict then kn `mappend` "'" else kn - conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef - -keyConExp :: EntityDef -> Exp -keyConExp = ConE . keyConName - -keyString :: EntityDef -> String -keyString = unpack . keyText - -keyText :: EntityDef -> Text -keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key" - -- | Returns 'True' if the key definition has more than 1 field. -- -- @since 2.11.0.0 @@ -1047,11 +992,6 @@ , ftToType $ fieldType fieldDef ) -keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name -keyFieldName mps entDef fieldDef - | pkNewtype mps entDef = unKeyName entDef - | otherwise = mkName $ unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef) - mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec mkKeyToValues mps entDef = do (p, e) <- case entityPrimary entDef of @@ -1141,10 +1081,9 @@ if mpsGeneric mps then liftAndFixKeys entityMap entDef else makePersistEntityDefExp mps entityMap entDef - let nameT = unEntityNameHS entName - let nameS = unpack nameT + let name = mkEntityDefName entDef let clazz = ConT ''PersistEntity `AppT` genDataType - tpf <- mkToPersistFields mps nameS entDef + tpf <- mkToPersistFields mps entDef fpv <- mkFromPersistValues mps entDef utv <- mkUniqueToValues $ entityUniques entDef puk <- mkUniqueKeys entDef @@ -1160,7 +1099,7 @@ let addSyn -- FIXME maybe remove this | mpsGeneric mps = (:) $ - TySynD (mkName nameS) [] $ + TySynD name [] $ genericDataType mps entName $ mpsBackend mps | otherwise = id @@ -1175,9 +1114,7 @@ Just prim -> do recordName <- newName "record" let keyCon = keyConName entDef - keyFields' = - map (mkName . T.unpack . recNameF mps entName . fieldHaskell) - (compositeFields prim) + keyFields' = fieldDefToRecordName mps entDef <$> compositeFields prim constr = foldl' AppE @@ -1198,7 +1135,7 @@ return $ addSyn $ dtd : mconcat fkc `mappend` ([ TySynD (keyIdName entDef) [] $ - ConT ''Key `AppT` ConT (mkName nameS) + ConT ''Key `AppT` ConT name , instanceD instanceConstraint clazz [ uniqueTypeDec mps entDef , keyTypeDec @@ -1268,7 +1205,7 @@ withPersistStoreWriteCxt = if mpsGeneric mps then do - write <- [t|PersistStoreWrite $(pure (VarT $ mkName "backend")) |] + write <- [t|PersistStoreWrite $(pure backendT) |] pure [write] else do pure [] @@ -1330,9 +1267,8 @@ mkLenses mps _ | not (mpsGenerateLenses mps) = return [] mkLenses _ ent | entitySum ent = return [] mkLenses mps ent = fmap mconcat $ forM (entityFields ent) $ \field -> do - let lensName' = recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) - lensName = mkName $ unpack lensName' - fieldName = mkName $ unpack $ "_" ++ lensName' + let lensName = mkName $ T.unpack $ recNameNoUnderscore mps (entityHaskell ent) (fieldHaskell field) + fieldName = fieldDefToRecordName mps ent field needleN <- newName "needle" setterN <- newName "setter" fN <- newName "f" @@ -1378,11 +1314,11 @@ mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec] mkForeignKeysComposite mps entDef ForeignDef {..} = if not foreignToPrimary then return [] else do - let fieldName f = mkName $ unpack $ recNameF mps (entityHaskell entDef) f + let fieldName = fieldNameToRecordName mps entDef let fname = fieldName (constraintToField foreignConstraintNameHaskell) let reftableString = unpack $ unEntityNameHS foreignRefTableHaskell let reftableKeyName = mkName $ reftableString `mappend` "Key" - let tablename = mkName $ unpack $ entityText entDef + let tablename = mkEntityDefName entDef recordName <- newName "record" let mkFldE ((foreignName, _),ff) = case ff of @@ -1566,8 +1502,8 @@ let entityListName = mkName entityList edefs <- fmap ListE . forM entityDefs - $ \(EntityDef { entityHaskell = EntityNameHS haskellName }) -> - let entityType = conT (mkName (T.unpack haskellName)) + $ \entDef -> + let entityType = entityDefConT entDef in [|entityDef (Proxy :: Proxy $(entityType))|] typ <- [t|[EntityDef]|] pure @@ -1589,13 +1525,13 @@ return (x, x') let pcs = map (go xs) $ entityUniques def let pat = ConP - (mkName $ unpack $ unEntityNameHS $ entityHaskell def) + (mkEntityDefName def) (map (VarP . snd) xs) return $ normalClause [pat] (ListE pcs) go :: [(FieldNameHS, Name)] -> UniqueDef -> Exp go xs (UniqueDef name _ cols _) = - foldl' (go' xs) (ConE (mkName $ unpack $ unConstraintNameHS name)) (map fst cols) + foldl' (go' xs) (ConE (mkConstraintName name)) (map fst cols) go' :: [(FieldNameHS, Name)] -> Exp -> FieldNameHS -> Exp go' xs front col = @@ -1799,26 +1735,6 @@ maybeNullable :: FieldDef -> Bool maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr -filterConName :: MkPersistSettings - -> EntityDef - -> FieldDef - -> Name -filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) - -filterConName' :: MkPersistSettings - -> EntityNameHS - -> FieldNameHS - -> Name -filterConName' mps entity field = mkName $ unpack name - where - name - | field == FieldNameHS "Id" = entityName ++ fieldName - | mpsPrefixFields mps = modifiedName - | otherwise = fieldName - modifiedName = mpsConstraintLabelModifier mps entityName fieldName - entityName = unEntityNameHS entity - fieldName = upperFirst $ unFieldNameHS field - ftToType :: FieldType -> Type ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t -- This type is generated from the Quasi-Quoter. @@ -1846,8 +1762,7 @@ obj <- newName "obj" mzeroE <- [|mzero|] - xs <- mapM (newName . unpack . unFieldNameHSForJSON . fieldHaskell) - $ entityFields def + xs <- mapM fieldToJSONValName (entityFields def) let conName = mkName $ unpack $ unEntityNameHS $ entityHaskell def typ = genericDataType mps (entityHaskell def) backendT @@ -1955,18 +1870,23 @@ mkSymbolToFieldInstances :: MkPersistSettings -> EntityDef -> Q [Dec] mkSymbolToFieldInstances mps ed = do - fmap join $ forM (entityFields ed) $ \fieldDef -> do - let fieldNameT = - litT $ strTyLit $ T.unpack $ unFieldNameHS $ fieldHaskell fieldDef - :: Q Type + fmap join $ forM (keyAndEntityFields ed) $ \fieldDef -> do + let fieldNameT :: Q Type + fieldNameT = + litT $ strTyLit + $ T.unpack $ lowerFirstIfId + $ unFieldNameHS $ fieldHaskell fieldDef + + lowerFirstIfId "Id" = "id" + lowerFirstIfId xs = xs - nameG = mkName $ unpack $ unEntityNameHS (entityHaskell ed) ++ "Generic" + nameG = mkEntityDefGenericName ed recordNameT | mpsGeneric mps = conT nameG `appT` varT backendName | otherwise = - conT $ mkName $ T.unpack $ unEntityNameHS $ entityHaskell ed + entityDefConT ed fieldTypeT = maybeIdType mps fieldDef Nothing Nothing @@ -2012,3 +1932,137 @@ where extensionToPragma ext = "{-# LANGUAGE " <> show ext <> " #-}" + +-- | creates a TH Name for use in the ToJSON instance +fieldToJSONValName :: FieldDef -> Q Name +fieldToJSONValName = + newName . T.unpack . unFieldNameHSForJSON . fieldHaskell + +-- | This special-cases "type_" and strips out its underscore. When +-- used for JSON serialization and deserialization, it works around +-- <https://github.com/yesodweb/persistent/issues/412> +unFieldNameHSForJSON :: FieldNameHS -> Text +unFieldNameHSForJSON = fixTypeUnderscore . unFieldNameHS + where + fixTypeUnderscore = \case + "type" -> "type_" + name -> name + +entityDefConK :: EntityDef -> Kind +entityDefConK = conK . mkEntityDefName + +entityDefConT :: EntityDef -> Q Type +entityDefConT = pure . entityDefConK + +entityDefConE :: EntityDef -> Exp +entityDefConE = ConE . mkEntityDefName + +-- | creates a TH Name for an entity's field, based on the entity +-- name and the field name, so for example: +-- +-- Customer +-- name Text +-- +-- This would generate `customerName` as a TH Name +fieldNameToRecordName :: MkPersistSettings -> EntityDef -> FieldNameHS -> Name +fieldNameToRecordName mps entDef fieldName = mkName $ T.unpack $ recNameF mps (entityHaskell entDef) fieldName + +-- | as above, only takes a `FieldDef` +fieldDefToRecordName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +fieldDefToRecordName mps entDef fieldDef = fieldNameToRecordName mps entDef (fieldHaskell fieldDef) + +-- | Construct a list of TH Names for the typeclasses of an EntityDef's `entityDerives` +mkEntityDefDeriveNames :: MkPersistSettings -> EntityDef -> [Name] +mkEntityDefDeriveNames mps entDef = + let entityInstances = mkName . T.unpack <$> entityDerives entDef + additionalInstances = filter (`notElem` entityInstances) $ mpsDeriveInstances mps + in entityInstances <> additionalInstances + +-- | Make a TH Name for the EntityDef's Haskell type +mkEntityNameHSName :: EntityNameHS -> Name +mkEntityNameHSName = + mkName . T.unpack . unEntityNameHS + +-- | As above only taking an `EntityDef` +mkEntityDefName :: EntityDef -> Name +mkEntityDefName = + mkEntityNameHSName . entityHaskell + +-- | Make a TH Name for the EntityDef's Haskell type, when using mpsGeneric +mkEntityDefGenericName :: EntityDef -> Name +mkEntityDefGenericName = + mkEntityNameHSGenericName . entityHaskell + +mkEntityNameHSGenericName :: EntityNameHS -> Name +mkEntityNameHSGenericName name = + mkName $ T.unpack (unEntityNameHS name <> "Generic") + +sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +sumConstrName mps entDef FieldDef {..} = mkName $ T.unpack name + where + name + | mpsPrefixFields mps = modifiedName ++ "Sum" + | otherwise = fieldName ++ "Sum" + modifiedName = mpsConstraintLabelModifier mps entityName fieldName + entityName = unEntityNameHS $ entityHaskell entDef + fieldName = upperFirst $ unFieldNameHS fieldHaskell + +-- | Turn a ConstraintName into a TH Name +mkConstraintName :: ConstraintNameHS -> Name +mkConstraintName (ConstraintNameHS name) = + mkName (T.unpack name) + +keyIdName :: EntityDef -> Name +keyIdName = mkName . T.unpack . keyIdText + +keyIdText :: EntityDef -> Text +keyIdText entDef = unEntityNameHS (entityHaskell entDef) `mappend` "Id" + +unKeyName :: EntityDef -> Name +unKeyName entDef = mkName $ T.unpack $ "un" `mappend` keyText entDef + +unKeyExp :: EntityDef -> Exp +unKeyExp = VarE . unKeyName + +backendT :: Type +backendT = VarT backendName + +backendName :: Name +backendName = mkName "backend" + +keyConName :: EntityDef -> Name +keyConName entDef = mkName $ T.unpack $ resolveConflict $ keyText entDef + where + resolveConflict kn = if conflict then kn `mappend` "'" else kn + conflict = any ((== FieldNameHS "key") . fieldHaskell) $ entityFields entDef + +keyConExp :: EntityDef -> Exp +keyConExp = ConE . keyConName + +keyText :: EntityDef -> Text +keyText entDef = unEntityNameHS (entityHaskell entDef) ++ "Key" + +keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name +keyFieldName mps entDef fieldDef + | pkNewtype mps entDef = unKeyName entDef + | otherwise = mkName $ T.unpack $ lowerFirst (keyText entDef) `mappend` unFieldNameHS (fieldHaskell fieldDef) + +filterConName :: MkPersistSettings + -> EntityDef + -> FieldDef + -> Name +filterConName mps entity field = filterConName' mps (entityHaskell entity) (fieldHaskell field) + +filterConName' :: MkPersistSettings + -> EntityNameHS + -> FieldNameHS + -> Name +filterConName' mps entity field = mkName $ T.unpack name + where + name + | field == FieldNameHS "Id" = entityName ++ fieldName + | mpsPrefixFields mps = modifiedName + | otherwise = fieldName + modifiedName = mpsConstraintLabelModifier mps entityName fieldName + entityName = unEntityNameHS entity + fieldName = upperFirst $ unFieldNameHS field diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/persistent.cabal new/persistent-2.12.1.1/persistent.cabal --- old/persistent-2.12.0.2/persistent.cabal 2021-04-01 18:42:09.000000000 +0200 +++ new/persistent-2.12.1.1/persistent.cabal 2021-04-20 15:18:24.000000000 +0200 @@ -1,5 +1,5 @@ name: persistent -version: 2.12.0.2 +version: 2.12.1.1 license: MIT license-file: LICENSE author: Michael Snoyman <mich...@snoyman.com> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/test/Database/Persist/TH/OverloadedLabelSpec.hs new/persistent-2.12.1.1/test/Database/Persist/TH/OverloadedLabelSpec.hs --- old/persistent-2.12.0.2/test/Database/Persist/TH/OverloadedLabelSpec.hs 2021-03-26 20:15:27.000000000 +0100 +++ new/persistent-2.12.1.1/test/Database/Persist/TH/OverloadedLabelSpec.hs 2021-04-20 15:18:24.000000000 +0200 @@ -52,5 +52,11 @@ compiles + it "works for id labels" $ do + let UserId = #id + orgId = #id :: EntityField Organization OrganizationId + + compiles + compiles :: Expectation compiles = True `shouldBe` True diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.12.0.2/test/main.hs new/persistent-2.12.1.1/test/main.hs --- old/persistent-2.12.0.2/test/main.hs 2021-04-01 18:42:09.000000000 +0200 +++ new/persistent-2.12.1.1/test/main.hs 2021-04-20 23:24:19.000000000 +0200 @@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} @@ -9,7 +9,7 @@ import qualified Data.Char as Char import qualified Data.Text as T import Data.List -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map #if !MIN_VERSION_base(4,11,0) @@ -34,8 +34,8 @@ THSpec.spec describe "splitExtras" $ do - let helloWorldTokens = asTokens ["hello", "world"] - foobarbazTokens = asTokens ["foo", "bar", "baz"] + let helloWorldTokens = Token "hello" :| [Token "world"] + foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"] it "works" $ do splitExtras [] `shouldBe` @@ -45,20 +45,21 @@ [ Line 0 helloWorldTokens ] `shouldBe` - ( [helloWorldTokens], mempty ) + ( [NEL.toList helloWorldTokens], mempty ) it "works3" $ do splitExtras [ Line 0 helloWorldTokens , Line 2 foobarbazTokens ] `shouldBe` - ( [helloWorldTokens, foobarbazTokens], mempty ) + ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty ) it "works4" $ do let foobarbarz = ["foo", "Bar", "baz"] + fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras - [ Line 0 [Token "Hello"] - , Line 2 (asTokens foobarbarz) - , Line 2 (asTokens foobarbarz) + [ Line 0 (pure (Token "Hello")) + , Line 2 fbbTokens + , Line 2 fbbTokens ] `shouldBe` ( [] @@ -68,10 +69,11 @@ ) it "works5" $ do let foobarbarz = ["foo", "Bar", "baz"] + fbbTokens = Token <$> nonEmptyOrFail foobarbarz splitExtras - [ Line 0 (asTokens ["Hello"]) - , Line 2 (asTokens foobarbarz) - , Line 4 (asTokens foobarbarz) + [ Line 0 (pure (Token "Hello")) + , Line 2 fbbTokens + , Line 4 fbbTokens ] `shouldBe` ( [] @@ -138,7 +140,7 @@ it "handles normal words" $ parseLine " foo bar baz" `shouldBe` Just - ( Line 1 + ( Line 1 $ nonEmptyOrFail [ Token "foo" , Token "bar" , Token "baz" @@ -148,7 +150,7 @@ it "handles quotes" $ parseLine " \"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "foo bar" , Token "baz" ] @@ -157,7 +159,7 @@ it "handles quotes mid-token" $ parseLine " x=\"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "x=foo bar" , Token "baz" ] @@ -166,7 +168,7 @@ it "handles escaped quote mid-token" $ parseLine " x=\\\"foo bar\" \"baz\"" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "x=\\\"foo" , Token "bar\"" , Token "baz" @@ -176,7 +178,7 @@ it "handles unnested parantheses" $ parseLine " (foo bar) (baz)" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "foo bar" , Token "baz" ] @@ -185,7 +187,7 @@ it "handles unnested parantheses mid-token" $ parseLine " x=(foo bar) (baz)" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "x=foo bar" , Token "baz" ] @@ -194,7 +196,7 @@ it "handles nested parantheses" $ parseLine " (foo (bar)) (baz)" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "foo (bar)" , Token "baz" ] @@ -203,7 +205,7 @@ it "escaping" $ parseLine " (foo \\(bar) y=\"baz\\\"\"" `shouldBe` Just - ( Line 2 + ( Line 2 $ nonEmptyOrFail [ Token "foo (bar" , Token "y=baz\"" ] @@ -212,7 +214,7 @@ it "mid-token quote in later token" $ parseLine "foo bar baz=(bin\")" `shouldBe` Just - ( Line 0 + ( Line 0 $ nonEmptyOrFail [ Token "foo" , Token "bar" , Token "baz=bin\"" @@ -223,22 +225,13 @@ it "recognizes one line" $ do parseLine "-- | this is a comment" `shouldBe` Just - ( Line 0 - [ DocComment "this is a comment" - ] + ( Line 0 $ pure + (DocComment "this is a comment") ) - it "map parseLine" $ do - mapM parseLine ["Foo", "-- | Hello"] - `shouldBe` - Just - [ Line 0 [Token "Foo"] - , Line 0 [DocComment "Hello"] - ] - it "works if comment is indented" $ do parseLine " -- | comment" `shouldBe` - Just (Line 2 [ DocComment "comment"]) + Just (Line 2 (pure (DocComment "comment"))) describe "parse" $ do let subject = @@ -415,9 +408,7 @@ it "preparse works" $ do (length <$> preparsed) `shouldBe` Just 10 - let skippedEmpty = - maybe [] skipEmpty preparsed - fooLines = + let fooLines = [ Line { lineIndent = 0 , tokens = Token "Foo" :| [] @@ -465,19 +456,11 @@ , tokens = Token "c" :| [Token "FooId"] } ] - resultLines = - concat - [ fooLines - , emptyLines - , barLines - , bazLines - ] - - it "skipEmpty works" $ do - skippedEmpty `shouldBe` resultLines let linesAssociated = - associateLines skippedEmpty + case preparsed of + Nothing -> error "preparsed failed" + Just lines -> associateLines lines it "associateLines works" $ do linesAssociated `shouldMatchList` [ LinesWithComments @@ -529,20 +512,20 @@ it "recognizes entity" $ do let expected = - Line { lineIndent = 0, tokens = asTokens ["Person"] } :| - [ Line { lineIndent = 2, tokens = asTokens ["name", "String"] } - , Line { lineIndent = 2, tokens = asTokens ["age", "Int"] } + Line { lineIndent = 0, tokens = pure (Token "Person") } :| + [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] } + , Line { lineIndent = 2, tokens = Token "age" :| [Token "Int"] } ] preparse "Person\n name String\n age Int" `shouldBe` Just expected it "recognizes comments" $ do let text = "Foo\n x X\n-- | Hello\nBar\n name String" let expected = - Line { lineIndent = 0, tokens = asTokens ["Foo"] } :| - [ Line { lineIndent = 2, tokens = asTokens ["x", "X"] } - , Line { lineIndent = 0, tokens = [DocComment "Hello"] } - , Line { lineIndent = 0, tokens = asTokens ["Bar"] } - , Line { lineIndent = 1, tokens = asTokens ["name", "String"] } + Line { lineIndent = 0, tokens = pure (Token "Foo") } :| + [ Line { lineIndent = 2, tokens = Token "x" :| [Token "X"] } + , Line { lineIndent = 0, tokens = pure (DocComment "Hello") } + , Line { lineIndent = 0, tokens = pure (Token "Bar") } + , Line { lineIndent = 1, tokens = Token "name" :| [Token "String"] } ] preparse text `shouldBe` Just expected @@ -556,11 +539,11 @@ , " name String" ] expected = - Line { lineIndent = 2, tokens = asTokens ["Foo"] } :| - [ Line { lineIndent = 4, tokens = asTokens ["x", "X"] } - , Line { lineIndent = 2, tokens = [DocComment "Comment"] } - , Line { lineIndent = 2, tokens = asTokens ["Bar"] } - , Line { lineIndent = 4, tokens = asTokens ["name", "String"] } + Line { lineIndent = 2, tokens = pure (Token "Foo") } :| + [ Line { lineIndent = 4, tokens = Token "x" :| [Token "X"] } + , Line { lineIndent = 2, tokens = pure (DocComment "Comment") } + , Line { lineIndent = 2, tokens = pure (Token "Bar") } + , Line { lineIndent = 4, tokens = Token "name" :| [Token "String"] } ] preparse t `shouldBe` Just expected @@ -575,13 +558,13 @@ , " something" ] expected = - Line { lineIndent = 0, tokens = asTokens ["LowerCaseTable"] } :| - [ Line { lineIndent = 2, tokens = asTokens ["name", "String"] } - , Line { lineIndent = 2, tokens = asTokens ["ExtraBlock"] } - , Line { lineIndent = 4, tokens = asTokens ["foo", "bar"] } - , Line { lineIndent = 4, tokens = asTokens ["baz"] } - , Line { lineIndent = 2, tokens = asTokens ["ExtraBlock2"] } - , Line { lineIndent = 4, tokens = asTokens ["something"] } + Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :| + [ Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] } + , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock") } + , Line { lineIndent = 4, tokens = Token "foo" :| [Token "bar"] } + , Line { lineIndent = 4, tokens = pure (Token "baz") } + , Line { lineIndent = 2, tokens = pure (Token "ExtraBlock2") } + , Line { lineIndent = 4, tokens = pure (Token "something") } ] preparse t `shouldBe` Just expected @@ -593,10 +576,10 @@ , " name String" ] expected = - Line { lineIndent = 0, tokens = [DocComment "Model"] } :| - [ Line { lineIndent = 0, tokens = asTokens ["Foo"] } - , Line { lineIndent = 2, tokens = [DocComment "Field"] } - , Line { lineIndent = 2, tokens = asTokens ["name", "String"] } + Line { lineIndent = 0, tokens = pure (DocComment "Model") } :| + [ Line { lineIndent = 0, tokens = pure (Token "Foo") } + , Line { lineIndent = 2, tokens = pure (DocComment "Field") } + , Line { lineIndent = 2, tokens = Token "name" :| [Token "String"] } ] preparse text `shouldBe` Just expected @@ -618,10 +601,10 @@ } it "works" $ do associateLines - [ comment - , foo + ( comment :| + [ foo , name'String - ] + ]) `shouldBe` [ LinesWithComments { lwcComments = ["comment"] @@ -631,7 +614,7 @@ let bar = Line { lineIndent = 0 - , tokens = Token "Bar" :| asTokens ["sql", "=", "bars"] + , tokens = Token "Bar" :| [Token "sql", Token "=", Token "bars"] } age'Int = Line @@ -640,12 +623,12 @@ } it "works when used consecutively" $ do associateLines - [ bar - , age'Int + ( bar :| + [ age'Int , comment , foo , name'String - ] + ]) `shouldBe` [ LinesWithComments { lwcComments = [] @@ -657,11 +640,9 @@ } ] it "works with textual input" $ do - let text = "Foo\n x X\n-- | Hello\nBar\n name String" - parsed = preparse text - allFull = maybe [] skipEmpty parsed - associateLines allFull - `shouldBe` + let text = preparse "Foo\n x X\n-- | Hello\nBar\n name String" + associateLines <$> text + `shouldBe` Just [ LinesWithComments { lwcLines = Line {lineIndent = 0, tokens = Token "Foo" :| []} @@ -678,7 +659,7 @@ } ] it "works with extra blocks" $ do - let text = maybe [] skipEmpty . preparse . T.unlines $ + let text = preparse . T.unlines $ [ "LowerCaseTable" , " Id sql=my_id" , " fullName Text" @@ -689,7 +670,7 @@ , " ExtraBlock2" , " something" ] - associateLines text `shouldBe` + associateLines <$> text `shouldBe` Just [ LinesWithComments { lwcLines = Line { lineIndent = 0, tokens = pure (Token "LowerCaseTable") } :| @@ -707,7 +688,7 @@ ] it "works with extra blocks twice" $ do - let text = maybe [] skipEmpty . preparse . T.unlines $ + let text = preparse . T.unlines $ [ "IdTable" , " Id Day default=CURRENT_DATE" , " name Text" @@ -722,11 +703,11 @@ , " ExtraBlock2" , " something" ] - associateLines text `shouldBe` + associateLines <$> text `shouldBe` Just [ LinesWithComments { lwcLines = Line 0 (pure (Token "IdTable")) :| - [ Line 4 (Token "Id" :| asTokens ["Day", "default=CURRENT_DATE"]) - , Line 4 (Token "name" :| asTokens ["Text"]) + [ Line 4 (Token "Id" <| Token "Day" :| [Token "default=CURRENT_DATE"]) + , Line 4 (Token "name" :| [Token "Text"]) ] , lwcComments = [] } @@ -748,13 +729,13 @@ it "works with field comments" $ do - let text = maybe [] skipEmpty . preparse . T.unlines $ + let text = preparse . T.unlines $ [ "-- | Model" , "Foo" , " -- | Field" , " name String" ] - associateLines text `shouldBe` + associateLines <$> text `shouldBe` Just [ LinesWithComments { lwcLines = Line { lineIndent = 0, tokens = (Token "Foo") :| [] } :| @@ -829,7 +810,7 @@ , "" ] of [a, b, c] -> - [a, b, c] + [a, b, c] :: [EntityDef] xs -> error $ "Expected 3 elements in list, got: " @@ -900,8 +881,11 @@ takePrefix (String a) = String (T.take 1 a) takePrefix a = a -asTokens :: [T.Text] -> [Token] -asTokens = fmap Token +nonEmptyOrFail :: [a] -> NonEmpty a +nonEmptyOrFail = maybe failure id . NEL.nonEmpty + where + failure = + error "nonEmptyOrFail expected a non empty list" arbitraryWhiteSpaceChar :: Gen Char arbitraryWhiteSpaceChar =
