persistent 2.13.3.0 → 2.13.3.1
raw patch · 5 files changed
+66/−32 lines, 5 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- ChangeLog.md +10/−0
- Database/Persist/Class/PersistField.hs +14/−9
- Database/Persist/TH.hs +32/−20
- persistent.cabal +2/−2
- test/Database/Persist/TH/JsonEncodingSpec.hs +8/−1
ChangeLog.md view
@@ -1,5 +1,15 @@ # Changelog for persistent +# 2.13.3.1++* [#1367](https://github.com/yesodweb/persistent/pull/1367),+ [#1366](https://github.com/yesodweb/persistent/pull/1367),+ [#1338](https://github.com/yesodweb/persistent/pull/1338),+ [#1335](https://github.com/yesodweb/persistent/pull/1335)+ * Support GHC 9.2+* [#1356](https://github.com/yesodweb/persistent/pull/1356)+ * Improve parse errors in generated FromJSON instances+ ## 2.13.3.0 * [#1341](https://github.com/yesodweb/persistent/pull/1341)
Database/Persist/Class/PersistField.hs view
@@ -19,6 +19,7 @@ import Data.Fixed import Data.Int (Int8, Int16, Int32, Int64) import qualified Data.IntMap as IM+import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as M import qualified Data.Set as S import Data.Text (Text)@@ -308,22 +309,26 @@ fromPersistValue x@(PersistText t) = let s = T.unpack t in- case reads s of- (d, _):_ -> Right d- _ ->+ case NonEmpty.nonEmpty (reads s) of+ Nothing -> case parse8601 s <|> parsePretty s of Nothing -> Left $ fromPersistValueParseError "UTCTime" x Just x' -> Right x'+ Just matches ->+ -- The 'Read UTCTime' instance in newer versions of 'time' is+ -- more flexible when parsing UTCTime strings and will return+ -- UTCTimes with different microsecond parsings. The last result+ -- here contains the parsed UTCTime with as much microsecond+ -- precision parsed as posssible.+ Right $ fst $ NonEmpty.last matches where #if MIN_VERSION_time(1,5,0)- parse8601 = parseTimeM True defaultTimeLocale format8601- parsePretty = parseTimeM True defaultTimeLocale formatPretty+ parseTime' = parseTimeM True defaultTimeLocale #else- parse8601 = parseTime defaultTimeLocale format8601- parsePretty = parseTime defaultTimeLocale formatPretty+ parseTime' = parseTime defaultTimeLocale #endif- format8601 = "%FT%T%Q"- formatPretty = "%F %T%Q"+ parse8601 = parseTime' "%FT%T%Q"+ parsePretty = parseTime' "%F %T%Q" fromPersistValue x@(PersistByteString s) = case reads $ unpack s of (d, _):_ -> Right d
Database/Persist/TH.hs view
@@ -130,6 +130,13 @@ import Database.Persist.ImplicitIdDef (autoIncrementingInteger) import Database.Persist.ImplicitIdDef.Internal +#if MIN_VERSION_template_haskell(2,18,0)+conp :: Name -> [Pat] -> Pat+conp name pats = ConP name [] pats+#else+conp = ConP+#endif+ -- | 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@@ -1287,7 +1294,7 @@ go = do xs <- sequence $ replicate fieldCount $ newName "x" let name = mkEntityDefName ed- pat = ConP name $ fmap VarP xs+ pat = conp name $ fmap VarP xs sp <- [|SomePersistField|] let bod = ListE $ fmap (AppE sp . VarE) xs return $ normalClause [pat] bod@@ -1309,7 +1316,7 @@ , [sp `AppE` VarE x] , after ]- return $ normalClause [ConP name [VarP x]] body+ return $ normalClause [conp name [VarP x]] body mkToFieldNames :: [UniqueDef] -> Q Dec mkToFieldNames pairs = do@@ -1331,7 +1338,7 @@ go :: UniqueDef -> Q Clause go (UniqueDef constr _ names _) = do xs <- mapM (const $ newName "x") names- let pat = ConP (mkConstraintName constr) $ fmap VarP $ toList xs+ let pat = conp (mkConstraintName constr) $ fmap VarP $ toList xs tpv <- [|toPersistValue|] let bod = ListE $ fmap (AppE tpv . VarE) $ toList xs return $ normalClause [pat] bod@@ -1370,7 +1377,7 @@ mkClauses _ [] = return [] mkClauses before (field:after) = do x <- newName "x"- let null' = ConP 'PersistNull []+ let null' = conp 'PersistNull [] pat = ListP $ mconcat [ fmap (const null') before , [VarP x]@@ -1407,20 +1414,20 @@ valName <- newName "value" xName <- newName "x" let idClause = normalClause- [ConP (keyIdName entDef) []]+ [conp (keyIdName entDef) []] (lens' `AppE` getId `AppE` setId) return $ idClause : if unboundEntitySum entDef then fmap (toSumClause lens' keyVar valName xName) (getUnboundFieldDefs entDef) else fmap (toClause lens' getVal dot keyVar valName xName) (getUnboundFieldDefs entDef) where toClause lens' getVal dot keyVar valName xName fieldDef = normalClause- [ConP (filterConName mps entDef fieldDef) []]+ [conp (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where fieldName = fieldDefToRecordName mps entDef fieldDef getter = InfixE (Just $ VarE fieldName) dot (Just getVal) setter = LamE- [ ConP 'Entity [VarP keyVar, VarP valName]+ [ conp 'Entity [VarP keyVar, VarP valName] , VarP xName ] $ ConE 'Entity `AppE` VarE keyVar `AppE` RecUpdE@@ -1428,20 +1435,20 @@ [(fieldName, VarE xName)] toSumClause lens' keyVar valName xName fieldDef = normalClause- [ConP (filterConName mps entDef fieldDef) []]+ [conp (filterConName mps entDef fieldDef) []] (lens' `AppE` getter `AppE` setter) where emptyMatch = Match WildP (NormalB $ VarE 'error `AppE` LitE (StringL "Tried to use fieldLens on a Sum type")) [] getter = LamE- [ ConP 'Entity [WildP, VarP valName]+ [ conp 'Entity [WildP, VarP valName] ] $ CaseE (VarE valName)- $ Match (ConP (sumConstrName mps entDef fieldDef) [VarP xName]) (NormalB $ VarE xName) []+ $ Match (conp (sumConstrName mps entDef fieldDef) [VarP xName]) (NormalB $ VarE xName) [] -- FIXME It would be nice if the types expressed that the Field is -- a sum type and therefore could result in Maybe. : if length (getUnboundFieldDefs entDef) > 1 then [emptyMatch] else [] setter = LamE- [ ConP 'Entity [VarP keyVar, WildP]+ [ conp 'Entity [VarP keyVar, WildP] , VarP xName ] $ ConE 'Entity `AppE` VarE keyVar `AppE` (ConE (sumConstrName mps entDef fieldDef) `AppE` VarE xName)@@ -2363,7 +2370,7 @@ x' <- newName $ '_' : unpack (unFieldNameHS x) return (x, x') let pcs = fmap (go xs) $ entityUniques $ unboundEntityDef def- let pat = ConP+ let pat = conp (mkEntityDefName def) (fmap (VarP . snd) xs) return $ normalClause [pat] (ListE pcs)@@ -2552,7 +2559,7 @@ maybeIdType mps entityMap fieldDef Nothing Nothing bod <- mkLookupEntityField et (unboundFieldNameHS fieldDef) let cla = normalClause- [ConP name []]+ [conp name []] bod return $ EntityFieldTH con cla where@@ -2582,7 +2589,7 @@ [mkEqualP (VarT $ mkName "typ") entityIdType] $ NormalC name [] , entityFieldTHClause =- normalClause [ConP name []] clause+ normalClause [conp name []] clause } lookupEntityField@@ -2648,8 +2655,8 @@ dotColonE <- [|(.:)|] dotColonQE <- [|(.:?)|] objectE <- [|object|]+ withObjectE <- [|withObject|] obj <- newName "obj"- mzeroE <- [|mzero|] let fields = getUnboundFieldDefs def@@ -2665,7 +2672,7 @@ typeInstanceD ''ToJSON (mpsGeneric mps) typ [toJSON'] where toJSON' = FunD 'toJSON $ return $ normalClause- [ConP conName $ fmap VarP xs]+ [conp conName $ fmap VarP xs] (objectE `AppE` ListE pairs) where pairs = zipWith toPair fields xs@@ -2676,15 +2683,19 @@ fromJSONI = typeInstanceD ''FromJSON (mpsGeneric mps) typ [parseJSON'] where- parseJSON' = FunD 'parseJSON- [ normalClause [ConP 'Object [VarP obj]]+ entNameStrLit =+ StringL $ T.unpack (unEntityNameHS (getUnboundEntityNameHS def))+ parseJSONBody =+ withObjectE `AppE` LitE entNameStrLit `AppE` decoderImpl+ parseJSON' =+ FunD 'parseJSON [ normalClause [] parseJSONBody ]+ decoderImpl =+ LamE [VarP obj] (foldl' (\x y -> InfixE (Just x) apE' (Just y)) (pureE `AppE` ConE conName) pulls )- , normalClause [WildP] mzeroE- ] where pulls = fmap toPull fields@@ -2692,6 +2703,7 @@ (Just $ VarE obj) (if maybeNullable f then dotColonQE else dotColonE) (Just $ AppE toKeyE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f)+ case mpsEntityJSON mps of Nothing -> return [toJSONI, fromJSONI]
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.13.3.0+version: 2.13.3.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -34,7 +34,7 @@ , resourcet >= 1.1.10 , scientific , silently- , template-haskell >= 2.13 && < 2.18+ , template-haskell >= 2.13 && < 2.19 , text >= 1.2 , th-lift-instances >= 0.1.14 && < 0.2 , time >= 1.6
test/Database/Persist/TH/JsonEncodingSpec.hs view
@@ -20,9 +20,9 @@ import Data.Aeson import Data.Text (Text)-import Test.QuickCheck.Instances () import Test.Hspec.QuickCheck import Test.QuickCheck+import Test.QuickCheck.Instances () import Database.Persist.EntityDef import Database.Persist.ImplicitIdDef@@ -87,6 +87,13 @@ eitherDecode json_ `shouldBe` Right subjectEntity++ it "has informative decoder errors" $ do+ let+ json_ = encode Null+ (eitherDecode json_ :: Either String JsonEncoding)+ `shouldBe`+ Left "Error in $: parsing JsonEncoding failed, expected Object, but encountered Null" prop "works with a Primary" $ \jsonEncoding -> do let