persistent-template 2.0.0.3 → 2.0.1
raw patch · 2 files changed
+102/−89 lines, 2 filesdep ~persistentPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: persistent
API changes (from Hackage documentation)
+ Database.Persist.TH: instance (Lift' k, Lift' v) => Lift' (Map k v)
+ Database.Persist.TH: instance Lift' Text
+ Database.Persist.TH: instance Lift' a => Lift' [a]
Files
- Database/Persist/TH.hs +100/−87
- persistent-template.cabal +2/−2
Database/Persist/TH.hs view
@@ -53,7 +53,7 @@ import Data.Text.Encoding (decodeUtf8) import qualified Data.Text.IO as TIO import Data.List (foldl')-import Data.Maybe (isJust, listToMaybe, mapMaybe)+import Data.Maybe (isJust, listToMaybe, mapMaybe, fromMaybe) import Data.Monoid (mappend, mconcat) import Text.Read (readPrec, lexP, step, prec, parens, Lexeme(Ident)) import qualified Data.Map as M@@ -151,7 +151,7 @@ data FieldSqlTypeExp = FieldSqlTypeExp FieldDef SqlTypeExp instance Lift FieldSqlTypeExp where lift (FieldSqlTypeExp (FieldDef{..}) sqlTypeExp) =- [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) $(liftTs fieldAttrs) fieldStrict fieldReference|]+ [|FieldDef fieldHaskell fieldDB fieldType $(lift sqlTypeExp) $(lift' fieldAttrs) fieldStrict fieldReference|] instance Lift EntityDefSqlTypeExp where lift (EntityDefSqlTypeExp (EntityDef{..}) sqlTypeExps) =@@ -159,13 +159,13 @@ $(lift entityHaskell) $(lift entityDB) $(lift entityID)- $(liftTs entityAttrs)+ $(lift' entityAttrs) $(lift (FieldsSqlTypeExp entityFields sqlTypeExps)) $(lift entityPrimary) $(lift entityUniques) $(lift entityForeigns)- $(liftTs entityDerives)- $(liftMap entityExtra)+ $(lift' entityDerives)+ $(lift' entityExtra) $(lift entitySum) |] @@ -350,7 +350,7 @@ mkCol x fd@FieldDef {..} = (mkName $ unpack $ recName mps x fieldHaskell, if fieldStrict then IsStrict else NotStrict,- pairToType mps backend (fd, nullable fieldAttrs)+ maybeIdType mps fd Nothing Nothing ) (nameFinal, paramsFinal) | mpsGeneric mps = (nameG, [PlainTV backend])@@ -358,7 +358,7 @@ nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Generic" name = mkName $ unpack $ unHaskellName $ entityHaskell t cols = map (mkCol $ entityHaskell t) $ entityFields t- backend = mkName "backend"+ backend = backendName constrs | entitySum t = map sumCon $ entityFields t@@ -366,7 +366,7 @@ sumCon fd = NormalC (sumConstrName mps t fd)- [(NotStrict, pairToType mps backend (fd, NotNullable))]+ [(NotStrict, maybeIdType mps fd Nothing Nothing)] sumConstrName :: MkPersistSettings -> EntityDef -> FieldDef -> Name sumConstrName mps t FieldDef {..} = mkName $ unpack $ concat@@ -381,13 +381,11 @@ uniqueTypeDec mps t = DataInstD [] ''Unique [genericDataType mps (entityHaskell t) backendT]- (map (mkUnique mps backend t) $ entityUniques t)+ (map (mkUnique mps t) $ entityUniques t) []- where- backend = mkName "backend" -mkUnique :: MkPersistSettings -> Name -> EntityDef -> UniqueDef -> Con-mkUnique mps backend t (UniqueDef (HaskellName constr) _ fields attrs) =+mkUnique :: MkPersistSettings -> EntityDef -> UniqueDef -> Con+mkUnique mps t (UniqueDef (HaskellName constr) _ fields attrs) = NormalC (mkName $ unpack constr) types where types = map (go . flip lookup3 (entityFields t))@@ -397,7 +395,7 @@ go :: (FieldDef, IsNullable) -> (Strict, Type) go (_, Nullable _) | not force = error nullErrMsg- go (fd, y) = (NotStrict, pairToType mps backend (fd, y))+ go (fd, y) = (NotStrict, maybeIdType mps fd Nothing (Just y)) lookup3 :: Text -> [FieldDef] -> (FieldDef, IsNullable) lookup3 s [] =@@ -416,13 +414,17 @@ , "on the end of the line that defines your uniqueness " , "constraint in order to disable this check. ***" ] -pairToType :: MkPersistSettings- -> Name -- ^ backend- -> (FieldDef, IsNullable)+maybeIdType :: MkPersistSettings+ -> FieldDef+ -> Maybe Name -- ^ backend+ -> Maybe IsNullable -> Type-pairToType mps backend (fd, Nullable ByMaybeAttr) =- ConT ''Maybe `AppT` idType mps backend fd-pairToType mps backend (fd, _) = idType mps backend fd+maybeIdType mps fd mbackend mnull = maybeTyp mayNullable idtyp+ where+ mayNullable = case mnull of+ (Just (Nullable ByMaybeAttr)) -> True+ _ -> maybeNullable fd+ idtyp = idType mps fd mbackend backendDataType :: MkPersistSettings -> Type backendDataType mps@@ -437,12 +439,12 @@ | mpsGeneric mps = ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` backend | otherwise = ConT $ mkName $ unpack typ' -idType :: MkPersistSettings -> Name -> FieldDef -> Type-idType mps backend fd =+idType :: MkPersistSettings -> FieldDef -> Maybe Name -> Type+idType mps fd mbackend = case foreignReference fd of Just typ' -> ConT ''Key- `AppT` genericDataType mps typ' (VarT backend)+ `AppT` genericDataType mps typ' (VarT $ fromMaybe backendName mbackend) Nothing -> ftToType typ where typ = fieldType fd@@ -549,10 +551,9 @@ , map (const null') after ] constr = ConE $ sumConstrName mps t field- fmap' <- [|fmap|] fs <- [|fromPersistValue $(return $ VarE x)|] let guard' = NormalG $ VarE 'isNotNull `AppE` VarE x- let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmap' (Just fs))]) []+ let clause = Clause [pat] (GuardedB [(guard', InfixE (Just constr) fmapE (Just fs))]) [] clauses <- mkClauses (field : before) after return $ clause : clauses @@ -561,6 +562,9 @@ lensPTH :: (s -> a) -> (s -> b -> t) -> Lens s t a b lensPTH sa sbt afb s = fmap (sbt s) (afb $ sa s) +fmapE :: Exp+fmapE = VarE 'fmap+ mkLensClauses :: MkPersistSettings -> EntityDef -> Q [Clause] mkLensClauses mps t = do lens' <- [|lensPTH|]@@ -710,8 +714,11 @@ unKeyName t = mkName $ "un" `mappend` keyString t backendT :: Type-backendT = VarT $ mkName "backend"+backendT = VarT backendName +backendName :: Name+backendName = mkName "backend"+ keyConName :: EntityDef -> Name keyConName = mkName . keyString @@ -728,15 +735,16 @@ mkKeyToValues _mps t = do (p, e) <- case entityPrimary t of Nothing ->- ([],) <$> [|backendKeyToValues . $(return $ VarE $ unKeyName t)|]+ ([],) <$> [|(:[]) . toPersistValue . $(return $ VarE $ unKeyName t)|] Just pdef ->- newName "record" >>= return . toValuesPrimary pdef+ return $ toValuesPrimary pdef return $ FunD 'keyToValues $ return $ normalClause p e where- toValuesPrimary pdef recordName =+ toValuesPrimary pdef = ( [VarP recordName] , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName t fd) `AppE` VarE recordName)) $ primaryFields pdef )+ recordName = mkName "record" normalClause :: [Pat] -> Exp -> Clause normalClause p e = Clause p (NormalB e) []@@ -745,7 +753,7 @@ mkKeyFromValues _mps t = do clauses <- case entityPrimary t of Nothing -> do- e <- [|fmap $(return keyConE) . backendKeyFromValues|]+ e <- [|fmap $(return keyConE) . fromPersistValue . headNote|] return $ [normalClause [] e] Just pdef -> fromValues t "keyFromValues" keyConE (primaryFields pdef)@@ -753,6 +761,12 @@ where keyConE = ConE (keyConName t) +headNote :: [PersistValue] -> PersistValue+headNote (x:[]) = x+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"@@ -769,8 +783,8 @@ x1 <- newName "x1" restNames <- mapM (\i -> newName $ "x" `mappend` show i) [2..length fieldsNE] (fpv1:mkPersistValues) <- mapM mkPvFromFd fieldsNE- fmapE <- [|(<$>)|]- let conApp = infixFromPersistValue fmapE fpv1 conE x1+ app1E <- [|(<$>)|]+ let conApp = infixFromPersistValue app1E fpv1 conE x1 applyE <- [|(<*>)|] let applyFromPersistValue = infixFromPersistValue applyE @@ -890,10 +904,10 @@ -- FIXME if we want to get really fancy, then: if this field is the -- *only* Id field present, then set backend1 and backend2 to different -- values- backend1 = mkName "backend"- backend2 = mkName "backend"- aT = pairToType mps backend1 (field, nullable $ fieldAttrs field)- bT = pairToType mps backend2 (field, nullable $ fieldAttrs field)+ backend1 = backendName+ backend2 = backendName+ aT = maybeIdType mps field (Just backend1) Nothing+ bT = maybeIdType mps field (Just backend2) Nothing mkST backend = genericDataType mps (entityHaskell ent) (VarT backend) sT = mkST backend1 tT = mkST backend2@@ -906,7 +920,7 @@ (sT `arrow` (VarT fT `AppT` tT)) , FunD lensName $ return $ Clause [VarP fN, VarP aN]- (NormalB $ VarE 'fmap+ (NormalB $ fmapE `AppE` setter `AppE` (f `AppE` needle)) [ FunD needleN [normalClause [] (VarE fieldName `AppE` a)]@@ -919,24 +933,32 @@ ] mkForeignKeysComposite :: MkPersistSettings -> EntityDef -> ForeignDef -> Q [Dec]-mkForeignKeysComposite mps t fdef = do+mkForeignKeysComposite mps t ForeignDef {..} = do let fieldName f = mkName $ unpack $ recName mps (entityHaskell t) f- let fname = fieldName $ foreignConstraintNameHaskell fdef- let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell fdef + let fname = fieldName foreignConstraintNameHaskell+ let reftableString = unpack $ unHaskellName $ foreignRefTableHaskell let reftableKeyName = mkName $ reftableString `mappend` "Key" let tablename = mkName $ unpack $ entityText t recordName <- newName "record" - let fldsE = map (\(a,_,_,_) -> VarE (fieldName a) `AppE` VarE recordName) $- foreignFields fdef- let mkKeyE = foldl' AppE (ConE reftableKeyName) fldsE+ let fldsE = map (\((foreignName, _),_) -> VarE (fieldName $ foreignName)+ `AppE` VarE recordName) foreignFields+ let mkKeyE = foldl' AppE (maybeExp foreignNullable $ ConE reftableKeyName) fldsE let fn = FunD fname [normalClause [VarP recordName] mkKeyE] - let t2 = ConT ''Key `AppT` ConT (mkName reftableString)+ let t2 = maybeTyp foreignNullable $ ConT ''Key `AppT` ConT (mkName reftableString) let sig = SigD fname $ (ArrowT `AppT` (ConT tablename)) `AppT` t2 return [sig, fn] +maybeExp :: Bool -> Exp -> Exp+maybeExp may exp | may = fmapE `AppE` exp+ | otherwise = exp+maybeTyp :: Bool -> Type -> Type+maybeTyp may typ | may = ConT ''Maybe `AppT` typ+ | otherwise = typ ++ -- | produce code similar to the following: -- -- @@@ -1060,10 +1082,10 @@ return $ InstanceD- [ ClassP ''PersistQuery [VarT $ mkName "backend"]- , EqualP (ConT ''PersistEntityBackend `AppT` entityT) (VarT $ mkName "backend")+ [ ClassP ''PersistQuery [backendT]+ , EqualP (ConT ''PersistEntityBackend `AppT` entityT) backendT ]- (ConT ''DeleteCascade `AppT` entityT `AppT` VarT (mkName "backend"))+ (ConT ''DeleteCascade `AppT` entityT `AppT` backendT) [ FunD 'deleteCascade [normalClause [VarP key] (DoE stmts)] ]@@ -1106,7 +1128,7 @@ InstanceD ctx (ConT clazz `AppT` typ) where ctx- | hasBackend = [ClassP ''PersistStore [VarT $ mkName "backend"]]+ | hasBackend = [ClassP ''PersistStore [backendT]] | otherwise = [] persistFieldInstanceD :: Bool -- ^ include PersistStore backend constraint@@ -1213,28 +1235,28 @@ return $ NoBindS $ m `AppE` defsExp `AppE` u instance Lift EntityDef where- lift (EntityDef a b c d e f g h i j k) =+ lift EntityDef{..} = [|EntityDef- $(lift a)- $(lift b)- $(lift c)- $(liftTs d)- $(lift e)- $(lift f)- $(lift g)- $(lift h)- $(liftTs i)- $(liftMap j)- $(lift k)+ $(lift entityHaskell)+ $(lift entityDB)+ $(lift entityID)+ $(lift' entityAttrs)+ $(lift entityFields)+ $(lift entityPrimary)+ $(lift entityUniques)+ $(lift entityForeigns)+ $(lift' entityDerives)+ $(lift' entityExtra)+ $(lift entitySum) |] instance Lift FieldDef where- lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(liftTs e) f g|]+ lift (FieldDef a b c d e f g) = [|FieldDef a b c $(lift' d) $(lift' e) f g|] instance Lift UniqueDef where- lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(liftTs d)|]+ lift (UniqueDef a b c d) = [|UniqueDef $(lift a) $(lift b) $(lift c) $(lift' d)|] instance Lift PrimaryDef where- lift (PrimaryDef a b) = [|PrimaryDef $(lift a) $(liftTs b)|]+ lift (PrimaryDef a b) = [|PrimaryDef $(lift a) $(lift' b)|] instance Lift ForeignDef where- lift (ForeignDef a b c d e f) = [|ForeignDef $(lift a) $(lift b) $(lift c) $(lift d) $(lift e) $(liftTs f)|]+ lift (ForeignDef a b c d e f g) = [|ForeignDef $(lift a) $(lift b) $(lift c) $(lift d) $(lift e) $(lift' f) $(lift g)|] -- | A hack to avoid orphans. class Lift' a where@@ -1250,7 +1272,14 @@ lift' () = [|()|] instance Lift' SqlTypeExp where lift' = lift+instance Lift' Text where+ lift' = liftT+instance Lift' a => Lift' [a] where+ lift' xs = do { xs' <- mapM lift' xs; return (ListE xs') }+instance (Lift' k, Lift' v) => Lift' (M.Map k v) where+ lift' m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|] + packPTH :: String -> Text packPTH = pack #if !MIN_VERSION_text(0, 11, 2)@@ -1260,17 +1289,8 @@ liftT :: Text -> Q Exp liftT t = [|packPTH $(lift (unpack t))|] -liftTs :: [Text] -> Q Exp-liftTs = fmap ListE . mapM liftT--liftTss :: [[Text]] -> Q Exp-liftTss = fmap ListE . mapM liftTs--liftMap :: M.Map Text [[Text]] -> Q Exp-liftMap m = [|M.fromList $(fmap ListE $ mapM liftPair $ M.toList m)|]--liftPair :: (Text, [[Text]]) -> Q Exp-liftPair (t, ts) = [|($(liftT t), $(liftTss ts))|]+liftPair :: (Lift' k, Lift' v) => (k, v) -> Q Exp+liftPair (k, v) = [|($(lift' k), $(lift' v))|] instance Lift HaskellName where lift (HaskellName t) = [|HaskellName $(liftT t)|]@@ -1327,7 +1347,7 @@ mkField mps et cd = do let con = ForallC []- [EqualP (VarT $ mkName "typ") maybeTyp]+ [EqualP (VarT $ mkName "typ") $ maybeIdType mps cd Nothing Nothing] $ NormalC name [] bod <- lift cd let cla = normalClause@@ -1336,17 +1356,10 @@ return (con, cla) where name = filterConName mps et cd- maybeTyp =- if nullable (fieldAttrs cd) == Nullable ByMaybeAttr- then ConT ''Maybe `AppT` typ- else typ- typ =- case foreignReference cd of- Just ft ->- ConT ''Key- `AppT` genericDataType mps ft backendT- Nothing -> ftToType $ fieldType cd +maybeNullable :: FieldDef -> Bool+maybeNullable fd = nullable (fieldAttrs fd) == Nullable ByMaybeAttr+ filterConName :: MkPersistSettings -> EntityDef -> FieldDef@@ -1414,7 +1427,7 @@ pulls = map toPull $ entityFields def toPull f = InfixE (Just $ VarE obj)- (if nullable (fieldAttrs f) == Nullable ByMaybeAttr then dotColonQE else dotColonE)+ (if maybeNullable f then dotColonQE else dotColonE) (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f) case mpsEntityJSON mps of Nothing -> return [toJSONI, fromJSONI]
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.0.0.3+version: 2.0.1 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 && < 2.1+ , persistent >= 2.0.1 && < 2.1 , monad-control >= 0.2 && < 0.4 , bytestring >= 0.9 , text >= 0.5