persistent-template 2.5.4 → 2.6.0
raw patch · 4 files changed
+59/−41 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- Database/Persist/TH.hs +52/−30
- persistent-template.cabal +3/−3
- test/main.hs +0/−8
ChangeLog.md view
@@ -1,3 +1,7 @@+## 2.6.0+* [persistent#846](https://github.com/yesodweb/persistent/pull/846): Improve error message when marshalling fails+* [persistent#826](https://github.com/yesodweb/persistent/pull/826): Change `Unique` derive `Show`+ ## 2.5.4 * [persistent#778](https://github.com/yesodweb/persistent/issues/778): Add `persistManyFileWith`.
Database/Persist/TH.hs view
@@ -524,7 +524,16 @@ Nothing #endif (map (mkUnique mps t) $ entityUniques t)- []+ (derivClause $ entityUniques t)+ where+ derivClause [] = []+#if MIN_VERSION_template_haskell(2,12,0)+ derivClause _ = [DerivClause Nothing [ConT ''Show]]+#elif MIN_VERSION_template_haskell(2,11,0)+ derivClause _ = [ConT ''Show]+#else+ derivClause _ = [''Show]+#endif mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) =@@ -665,9 +674,6 @@ mapLeft _ (Right r) = Right r mapLeft f (Left l) = Left (f l) -fieldError :: Text -> Text -> Text-fieldError fieldName err = "Couldn't parse field `" `mappend` fieldName `mappend` "` from database results: " `mappend` err- mkFromPersistValues :: MkPersistSettings -> EntityDef -> Q [Clause] mkFromPersistValues _ t@(EntityDef { entitySum = False }) = fromValues t "fromPersistValues" entE $ entityFields t@@ -971,37 +977,53 @@ headNote 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 fields- 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 [] = do- rightE <- [|Right|]- return $ normalClause [ListP []] (rightE `AppE` conE)- patternSuccess fieldsNE = do- x1 <- newName "x1"- restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fieldsNE]- (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE- app1E <- [|(<$>)|]- let conApp = infixFromPersistValue app1E fpv1 conE x1- applyE <- [|(A.<*>)|]- let applyFromPersistValue = infixFromPersistValue applyE+ 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 <- [|(A.<*>)|]+ let applyFromPersistValue = infixFromPersistValue applyE - return $ normalClause- [ListP $ map VarP (x1:restNames)]- (foldl' (\exp (name, fpv) -> applyFromPersistValue fpv exp name) conApp (zip restNames mkPersistValues))- where- infixFromPersistValue applyE fpv exp name =- UInfixE exp applyE (fpv `AppE` VarE name)- mkPvFromFd = mkPersistValue . unHaskellName . fieldHaskell- mkPersistValue fieldName = [|mapLeft (fieldError fieldName) . fromPersistValue|]+ 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)++ mkPersistValue field =+ [|mapLeft (fieldError t field) . fromPersistValue|]++fieldError :: EntityDef -> FieldDef -> Text -> Text+fieldError entity field err = mconcat+ [ "Couldn't parse field `"+ , fieldName+ , "` from table `"+ , tableName+ , "`. "+ , err+ ]+ where+ fieldName =+ unHaskellName (fieldHaskell field)++ tableName =+ unDBName (entityDB entity) mkEntity :: EntityMap -> MkPersistSettings -> EntityDef -> Q [Dec] mkEntity entMap mps t = do
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.5.4+version: 2.6.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -23,13 +23,13 @@ , text >= 0.5 , transformers >= 0.2 && < 0.6 , containers- , aeson >= 0.7 && < 1.3+ , aeson >= 0.7 && < 1.5 , aeson-compat >= 0.3.2.0 && < 0.4 , monad-logger , unordered-containers , tagged , path-pieces- , http-api-data >= 0.2 && < 0.4+ , http-api-data >= 0.2 , ghc-prim exposed-modules: Database.Persist.TH ghc-options: -Wall
test/main.hs view
@@ -50,14 +50,6 @@ deriving Show Eq |] -share [mkPersist sqlSettings { mpsGeneric = True , mpsGenerateLenses = True }] [persistLowerCase|-Foo- bar Text Maybe- baz BazId-Baz- bin Int-|]- arbitraryT :: Gen Text arbitraryT = pack A.<$> arbitrary