persistent-template 2.5.1.6 → 2.5.2
raw patch · 4 files changed
+51/−22 lines, 4 filesdep ~aesonPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson
API changes (from Hackage documentation)
Files
- ChangeLog.md +5/−0
- Database/Persist/TH.hs +32/−15
- persistent-template.cabal +3/−3
- test/main.hs +11/−4
ChangeLog.md view
@@ -1,3 +1,8 @@+## 2.5.2++* Fix incorrect `ToJSON`/`FromJSON` instance generation for generic+ backends+ ## 2.5.1.6 Allow non-null self-references in a list
Database/Persist/TH.hs view
@@ -7,9 +7,13 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-}++#if !MIN_VERSION_base(4,8,0) -- overlapping instances is for automatic lifting -- while avoiding an orphan of Lift for Text {-# LANGUAGE OverlappingInstances #-}+#endif+ -- | This module provides utilities for creating backends. Regular users do not -- need to use this module. module Database.Persist.TH@@ -45,7 +49,6 @@ import Prelude hiding ((++), take, concat, splitAt, exp) import Database.Persist-import Database.Persist.Class (HasPersistBackend(..), BaseBackend) import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql) import Database.Persist.Quasi import Language.Haskell.TH.Lib (@@ -73,11 +76,11 @@ , Value (Object), (.:), (.:?) , eitherDecodeStrict' )-import Control.Applicative (pure, (<$>), (<*>))+import Control.Applicative as A (pure, (<$>), (<*>)) import Database.Persist.Sql (sqlType) import Data.Proxy (Proxy (Proxy)) import Web.PathPieces (PathPiece(..))-import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe)+import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..)) import GHC.Generics (Generic) import qualified Data.Text.Encoding as TE @@ -246,7 +249,7 @@ Nothing -> NoReference Just name -> case M.lookup (HaskellName name) allEntities of Nothing -> NoReference- Just x -> ForeignRef (HaskellName name)+ Just _ -> ForeignRef (HaskellName name) -- This can get corrected in mkEntityDefSqlTypeExp (FTTypeCon (Just "Data.Int") "Int64") Right em -> if embeddedHaskell em /= entName@@ -256,7 +259,7 @@ else case fieldType field of FTList _ -> SelfReference _ -> error $ unpack $ unHaskellName entName- `mappend` ": a self reference must be a Maybe"+ `Data.Monoid.mappend` ": a self reference must be a Maybe" existing@_ -> existing } @@ -281,7 +284,7 @@ Nothing -> SqlTypeExp ft -- A ForeignRef is blindly set to an Int64 in setEmbedField -- correct that now- Just ent -> case entityPrimary ent of+ Just ent' -> case entityPrimary ent' of Nothing -> SqlTypeExp ft Just pdef -> case compositeFields pdef of [] -> error "mkEntityDefSqlTypeExp: no composite fields"@@ -306,7 +309,7 @@ -- 'EntityDef's. Works well with the persist quasi-quoter. mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec] mkPersist mps ents' = do- x <- fmap mconcat $ mapM (persistFieldFromEntity mps) ents+ x <- fmap Data.Monoid.mconcat $ mapM (persistFieldFromEntity mps) ents y <- fmap mconcat $ mapM (mkEntity entMap mps) ents z <- fmap mconcat $ mapM (mkJSON mps) ents return $ mconcat [x, y, z]@@ -416,10 +419,15 @@ dataTypeDec :: MkPersistSettings -> EntityDef -> Q Dec dataTypeDec mps t = do let names = map (mkName . unpack) $ entityDerives t-#if MIN_VERSION_template_haskell(2,11,0)+#if MIN_VERSION_template_haskell(2,12,0) DataD [] nameFinal paramsFinal Nothing constrs+ <$> fmap (pure . DerivClause Nothing) (mapM conT names)+#elif MIN_VERSION_template_haskell(2,11,0)+ DataD [] nameFinal paramsFinal+ Nothing+ constrs <$> mapM conT names #else return $ DataD [] nameFinal paramsFinal constrs names@@ -718,9 +726,14 @@ bi <- backendKeyI return (bi, allInstances) -#if MIN_VERSION_template_haskell(2,11,0)+#if MIN_VERSION_template_haskell(2,12,0) cxti <- mapM conT i let kd = if useNewtype+ then NewtypeInstD [] k [recordType] Nothing dec [DerivClause Nothing cxti]+ else DataInstD [] k [recordType] Nothing [dec] [DerivClause Nothing cxti]+#elif MIN_VERSION_template_haskell(2,11,0)+ cxti <- mapM conT i+ let kd = if useNewtype then NewtypeInstD [] k [recordType] Nothing dec cxti else DataInstD [] k [recordType] Nothing [dec] cxti #else@@ -736,7 +749,7 @@ k = ''Key recordType = genericDataType mps (entityHaskell t) backendT pfInstD = -- FIXME: generate a PersistMap instead of PersistList- [d|instance PersistField (Key $(pure recordType)) where+ [d|instance PersistField (Key $(A.pure recordType)) where toPersistValue = PersistList . keyToValues fromPersistValue (PersistList l) = keyFromValues l fromPersistValue got = error $ "fromPersistValue: expected PersistList, got: " `mappend` show got@@ -874,7 +887,7 @@ mkKeyToValues mps t = do (p, e) <- case entityPrimary t of Nothing ->- ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]+ ([],) A.<$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|] Just pdef -> return $ toValuesPrimary pdef return $ FunD 'keyToValues $ return $ normalClause p e@@ -924,7 +937,7 @@ (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE app1E <- [|(<$>)|] let conApp = infixFromPersistValue app1E fpv1 conE x1- applyE <- [|(<*>)|]+ applyE <- [|(A.<*>)|] let applyFromPersistValue = infixFromPersistValue applyE return $ normalClause@@ -1393,7 +1406,7 @@ 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 entMap of Nothing -> Nothing Just ent -> case fieldReference $ entityId ent of@@ -1435,7 +1448,11 @@ lift' m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|] -- auto-lifting, means instances are overlapping+#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPABLE #-} Lift' a => Lift a where+#else instance Lift' a => Lift a where+#endif lift = lift' packPTH :: String -> Text@@ -1597,9 +1614,9 @@ entityJSONIs <- if mpsGeneric mps then [d| #if MIN_VERSION_base(4, 6, 0)- instance PersistStore backend => ToJSON (Entity $(pure typ)) where+ instance PersistStore $(pure backendT) => ToJSON (Entity $(pure typ)) where toJSON = $(varE (entityToJSON entityJSON))- instance PersistStore backend => FromJSON (Entity $(pure typ)) where+ instance PersistStore $(pure backendT) => FromJSON (Entity $(pure typ)) where parseJSON = $(varE (entityFromJSON entityJSON)) #endif |]
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.5.1.6+version: 2.5.2 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 && < 0.12+ , aeson >= 0.7 && < 1.2 , aeson-compat >= 0.3.2.0 && < 0.4 , monad-logger , unordered-containers , tagged , path-pieces- , http-api-data >= 0.2 && < 0.3+ , http-api-data >= 0.2 && < 0.4 , ghc-prim exposed-modules: Database.Persist.TH ghc-options: -Wall
test/main.hs view
@@ -3,16 +3,21 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+module Main+ (+ -- avoid unused ident warnings+ module Main+ ) where import Test.Hspec import Test.Hspec.QuickCheck import Data.ByteString.Lazy.Char8 () import Test.QuickCheck.Arbitrary-import Control.Applicative ((<$>), (<*>), Const (..))+import Test.QuickCheck.Gen (Gen)+import Control.Applicative as A ((<$>), (<*>), Const (..)) import Data.Functor.Identity (Identity (..)) import Database.Persist import Database.Persist.TH-import Database.Persist.Types (PersistValue(..)) import Data.Text (Text, pack) import Data.Aeson @@ -53,10 +58,11 @@ bin Int |] -arbitraryT = pack <$> arbitrary+arbitraryT :: Gen Text+arbitraryT = pack A.<$> arbitrary instance Arbitrary Person where- arbitrary = Person <$> arbitraryT <*> arbitrary <*> arbitrary+ arbitrary = Person <$> arbitraryT A.<*> arbitrary <*> arbitrary instance Arbitrary Address where arbitrary = Address <$> arbitraryT <*> arbitraryT <*> arbitrary @@ -90,6 +96,7 @@ (person1 ^. (lpersonAddress . laddressCity)) `shouldBe` city1 (person1 & ((lpersonAddress . laddressCity) .~ city2)) `shouldBe` person2 +(&) :: a -> (a -> b) -> b x & f = f x (^.) :: s