persistent-template 2.0.7 → 2.0.8
raw patch · 2 files changed
+62/−49 lines, 2 filesdep ~persistent
Dependency ranges changed: persistent
Files
- Database/Persist/TH.hs +60/−47
- persistent-template.cabal +2/−2
Database/Persist/TH.hs view
@@ -4,7 +4,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-fields #-} -- overlapping instances is for automatic lifting -- while avoiding an orphan of Lift for Text@@ -44,7 +45,7 @@ import Prelude hiding ((++), take, concat, splitAt, exp) import Database.Persist-import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql, IsSqlKey (..))+import Database.Persist.Sql (Migration, migrate, SqlBackend, PersistFieldSql) import Database.Persist.Quasi import Language.Haskell.TH.Lib (varE) import Language.Haskell.TH.Quote@@ -622,23 +623,24 @@ then if not useNewtype then do pfDec <- pfInstD return (pfDec, [''Generic])- else do gi <- genericInstances+ else do gi <- genericNewtypeInstances return (gi, []) else if not useNewtype then do pfDec <- pfInstD return (pfDec, [''Show, ''Read, ''Eq, ''Ord, ''Generic]) else do- let addIsSqlKey = if not useSqlKey then id else (''IsSqlKey :)- return ([], addIsSqlKey [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON])+ let allInstances = [''Show, ''Read, ''Eq, ''Ord, ''PathPiece, ''PersistField, ''PersistFieldSql, ''ToJSON, ''FromJSON]+ if customKeyType+ then return ([], allInstances)+ else do+ bi <- backendKeyI+ return (bi, allInstances) let kd = if useNewtype then NewtypeInstD [] k [recordType] dec i else DataInstD [] k [recordType] [dec] i return (kd, instDecs) where- useSqlKey = mpsBackend mps == ConT ''SqlBackend- && (fieldSqlType (entityId t) `elem` [SqlInt64, SqlInt32])- dec = RecC (keyConName t) keyFields k = ''Key recordType = genericDataType mps (entityHaskell t) backendT@@ -657,57 +659,68 @@ -- ghc 7.6 cannot parse the left arrow Ident $() <- lexP keyPattern = BindS (ConP 'Ident [LitP $ keyStringL t]) + backendKeyGenericI =+ [d| instance PersistStore $(pure backendT) =>+ ToBackendKey $(pure backendT) $(pure recordType) where+ toBackendKey = $(return $ VarE $ unKeyName t)+ fromBackendKey = $(return $ ConE $ keyConName t)+ |]+ backendKeyI = let bdt = backendDataType mps in+ [d| instance ToBackendKey $(pure bdt) $(pure recordType) where+ toBackendKey = $(return $ VarE $ unKeyName t)+ fromBackendKey = $(return $ ConE $ keyConName t)+ |]+ -- truly unfortunate that TH doesn't support standalone deriving -- https://ghc.haskell.org/trac/ghc/ticket/8100- genericInstances = do- instances <- [|lexP|] >>= \lexPE -> [| step readPrec >>= return . ($(pure $ ConE $ keyConName t) )|] >>= \readE ->- [d|instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) where+ genericNewtypeInstances = do+ instances <- [|lexP|] >>= \lexPE -> [| step readPrec >>= return . ($(pure $ ConE $ keyConName t) )|] >>= \readE -> do+ alwaysInstances <-+ [d|instance Show (BackendKey $(pure backendT)) => Show (Key $(pure recordType)) where showsPrec i x = showParen (i > app_prec) $ (showString $ $(pure $ LitE $ keyStringL t) `mappend` " ") . showsPrec i ($(return $ VarE $ unKeyName t) x) where app_prec = (10::Int)- instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) where- readPrec = parens $ (prec app_prec $ $(pure $ DoE [keyPattern lexPE, NoBindS readE]))- where app_prec = (10::Int)- instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) where- x == y =- ($(return $ VarE $ unKeyName t) x) ==- ($(return $ VarE $ unKeyName t) y)- x /= y =- ($(return $ VarE $ unKeyName t) x) ==- ($(return $ VarE $ unKeyName t) y)- instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) where- compare x y = compare- ($(return $ VarE $ unKeyName t) x)- ($(return $ VarE $ unKeyName t) y)- instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) where- toPathPiece = toPathPiece . $(return $ VarE $ unKeyName t)- fromPathPiece = fmap $(return $ ConE $ keyConName t) . fromPathPiece- instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) where- toPersistValue = toPersistValue . $(return $ VarE $ unKeyName t)- fromPersistValue = fmap $(return $ ConE $ keyConName t) . fromPersistValue- instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) where- sqlType = sqlType . fmap $(return $ VarE $ unKeyName t)- instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) where- toJSON = toJSON . $(return $ VarE $ unKeyName t)- instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) where- parseJSON = fmap $(return $ ConE $ keyConName t) . parseJSON- |]- if not useSqlKey then return instances else do- sqlKeyInst <-- [d| instance IsSqlKey (BackendKey $(pure backendT)) => IsSqlKey (Key $(pure recordType)) where- toSqlKey = $(return $ ConE $ keyConName t) . toSqlKey- fromSqlKey = fromSqlKey . $(return $ VarE $ unKeyName t)- |]- return $ instances `mappend` sqlKeyInst+ instance Read (BackendKey $(pure backendT)) => Read (Key $(pure recordType)) where+ readPrec = parens $ (prec app_prec $ $(pure $ DoE [keyPattern lexPE, NoBindS readE]))+ where app_prec = (10::Int)+ instance Eq (BackendKey $(pure backendT)) => Eq (Key $(pure recordType)) where+ x == y =+ ($(return $ VarE $ unKeyName t) x) ==+ ($(return $ VarE $ unKeyName t) y)+ x /= y =+ ($(return $ VarE $ unKeyName t) x) ==+ ($(return $ VarE $ unKeyName t) y)+ instance Ord (BackendKey $(pure backendT)) => Ord (Key $(pure recordType)) where+ compare x y = compare+ ($(return $ VarE $ unKeyName t) x)+ ($(return $ VarE $ unKeyName t) y)+ instance PathPiece (BackendKey $(pure backendT)) => PathPiece (Key $(pure recordType)) where+ toPathPiece = toPathPiece . $(return $ VarE $ unKeyName t)+ fromPathPiece = fmap $(return $ ConE $ keyConName t) . fromPathPiece+ instance PersistField (BackendKey $(pure backendT)) => PersistField (Key $(pure recordType)) where+ toPersistValue = toPersistValue . $(return $ VarE $ unKeyName t)+ fromPersistValue = fmap $(return $ ConE $ keyConName t) . fromPersistValue+ instance PersistFieldSql (BackendKey $(pure backendT)) => PersistFieldSql (Key $(pure recordType)) where+ sqlType = sqlType . fmap $(return $ VarE $ unKeyName t)+ instance ToJSON (BackendKey $(pure backendT)) => ToJSON (Key $(pure recordType)) where+ toJSON = toJSON . $(return $ VarE $ unKeyName t)+ instance FromJSON (BackendKey $(pure backendT)) => FromJSON (Key $(pure recordType)) where+ parseJSON = fmap $(return $ ConE $ keyConName t) . parseJSON+ |] + if customKeyType then return alwaysInstances+ else fmap (alwaysInstances `mappend`) backendKeyGenericI+ return instances+ useNewtype = length keyFields < 2+ defaultIdType = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t) keyFields = case entityPrimary t of Just pdef -> map primaryKeyVar $ (compositeFields pdef)- -- TODO: an ADT for the entityId- Nothing -> if fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)+ Nothing -> if defaultIdType then [idKeyVar backendKeyType] else [idKeyVar $ ftToType $ fieldType $ entityId t]+ customKeyType = not defaultIdType || not useNewtype || isJust (entityPrimary t) primaryKeyVar fd = (keyFieldName t fd, NotStrict, ftToType $ fieldType fd) idKeyVar ft = (unKeyName t, NotStrict, ft)
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.0.7+version: 2.0.8 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -17,7 +17,7 @@ library build-depends: base >= 4 && < 5 , template-haskell- , persistent >= 2.0.7 && < 2.1+ , persistent >= 2.0.8 && < 2.1 , monad-control >= 0.2 && < 0.4 , bytestring >= 0.9 , text >= 0.5