persistent-template 0.9.0.2 → 1.0.0
raw patch · 2 files changed
+81/−17 lines, 2 filesdep ~persistentPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: persistent
API changes (from Hackage documentation)
Files
- Database/Persist/TH.hs +79/−15
- persistent-template.cabal +2/−2
Database/Persist/TH.hs view
@@ -132,7 +132,7 @@ dataTypeDec :: EntityDef -> Dec dataTypeDec t =- DataD [] nameG [KindedTV backend monadTransKind] [RecC name cols]+ DataD [] nameG [KindedTV backend monadTransKind] constrs $ map (mkName . unpack) $ entityDerives t where monadKind = StarK `ArrowK` StarK@@ -147,6 +147,21 @@ cols = map (mkCol $ unHaskellName $ entityHaskell t) $ entityFields t backend = mkName "backend" + constrs+ | entitySum t = map sumCon $ entityFields t+ | otherwise = [RecC name cols]++ sumCon fd@(FieldDef _ _ ty _) = NormalC+ (sumConstrName t fd)+ [(NotStrict, pairToType backend (ty, False))]++sumConstrName :: EntityDef -> FieldDef -> Name+sumConstrName t (FieldDef n _ _ _) = mkName $ unpack $ concat+ [ unHaskellName $ entityHaskell t+ , upperFirst $ unHaskellName n+ , "Sum"+ ]+ readMay :: Read a => String -> Maybe a readMay s = case reads s of@@ -211,19 +226,42 @@ in [Clause [WildP] (NormalB err) []] degen x = x -mkToPersistFields :: [(String, Int)] -> Q Dec-mkToPersistFields pairs = do- clauses <- mapM go pairs- return $ FunD (mkName "toPersistFields") $ degen clauses+mkToPersistFields :: String -> EntityDef -> Q Dec+mkToPersistFields constr ed@EntityDef { entitySum = isSum, entityFields = fields } = do+ clauses <-+ if isSum+ then sequence $ zipWith goSum fields [1..]+ else fmap return go+ return $ FunD (mkName "toPersistFields") clauses where- go :: (String, Int) -> Q Clause- go (constr, fields) = do- xs <- sequence $ replicate fields $ newName "x"+ go :: Q Clause+ go = do+ xs <- sequence $ replicate fieldCount $ newName "x" let pat = ConP (mkName constr) $ map VarP xs sp <- [|SomePersistField|] let bod = ListE $ map (AppE sp . VarE) xs return $ Clause [pat] (NormalB bod) [] + fieldCount = length fields++ goSum :: FieldDef -> Int -> Q Clause+ goSum fd idx = do+ let name = sumConstrName ed fd+ enull <- [|SomePersistField PersistNull|]+ let beforeCount = idx - 1+ afterCount = fieldCount - idx+ before = replicate beforeCount enull+ after = replicate afterCount enull+ x <- newName "x"+ sp <- [|SomePersistField|]+ let body = NormalB $ ListE $ mconcat+ [ before+ , [sp `AppE` VarE x]+ , after+ ]+ return $ Clause [ConP name [VarP x]] body []++ mkToFieldNames :: [UniqueDef] -> Q Dec mkToFieldNames pairs = do pairs' <- mapM go pairs@@ -282,15 +320,15 @@ (NormalB $ VarE (mkName "toPersistValue") `AppE` VarE x) [] -mkHalfDefined :: String -> Int -> Dec+mkHalfDefined :: Name -> Int -> Dec mkHalfDefined constr count' = FunD (mkName "halfDefined") [Clause [] (NormalB- $ foldl AppE (ConE $ mkName constr)+ $ foldl AppE (ConE constr) (replicate count' $ VarE $ mkName "undefined")) []] mkFromPersistValues :: EntityDef -> Q [Clause]-mkFromPersistValues t = do+mkFromPersistValues t@(EntityDef { entitySum = False }) = do nothing <- [|Left $(liftT "Invalid fromPersistValues input")|] let cons' = ConE $ mkName $ unpack $ unHaskellName $ entityHaskell t xs <- mapM (const $ newName "x") $ entityFields t@@ -306,7 +344,26 @@ ] where go ap' x y = InfixE (Just x) ap' (Just y)-+mkFromPersistValues t@(EntityDef { entitySum = True }) = do+ nothing <- [|Left $(liftT "Invalid fromPersistValues input")|]+ clauses <- mkClauses [] $ entityFields t+ return $ clauses `mappend` [Clause [WildP] (NormalB nothing) []]+ where+ mkClauses _ [] = return []+ mkClauses before (field:after) = do+ x <- newName "x"+ let null' = ConP 'PersistNull []+ pat = ListP $ mconcat+ [ map (const null') before+ , [VarP x]+ , map (const null') after+ ]+ constr = ConE $ sumConstrName t field+ fmap' <- [|fmap|]+ fs <- [|fromPersistValue $(return $ VarE x)|]+ let clause = Clause [pat] (NormalB $ InfixE (Just constr) fmap' (Just fs)) []+ clauses <- mkClauses (field : before) after+ return $ clause : clauses mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec] mkEntity mps t = do@@ -314,7 +371,7 @@ let nameT = unHaskellName $ entityHaskell t let nameS = unpack nameT let clazz = ConT ''PersistEntity `AppT` (ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend"))- tpf <- mkToPersistFields [(nameS, length $ entityFields t)]+ tpf <- mkToPersistFields nameS t fpv <- mkFromPersistValues t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t@@ -339,7 +396,11 @@ , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []] , tpf , FunD (mkName "fromPersistValues") fpv- , mkHalfDefined nameS $ length $ entityFields t+ , mkHalfDefined+ (if entitySum t+ then sumConstrName t (head $ entityFields t)+ else mkName nameS)+ (if entitySum t then 1 else length $ entityFields t) , toFieldNames , utv , puk@@ -505,6 +566,8 @@ ] mkUniqueKeys :: EntityDef -> Q Dec+mkUniqueKeys def | entitySum def =+ return $ FunD (mkName "persistUniqueKeys") [Clause [WildP] (NormalB $ ListE []) []] mkUniqueKeys def = do c <- clause return $ FunD (mkName "persistUniqueKeys") [c]@@ -603,7 +666,7 @@ undefinedEntityTH u = SigE u . ConT . mkName . unpack . unHaskellName . entityHaskell instance Lift EntityDef where- lift (EntityDef a b c d e f g h) =+ lift (EntityDef a b c d e f g h i) = [|EntityDef $(lift a) $(lift b)@@ -613,6 +676,7 @@ $(lift f) $(liftTs g) $(liftMap h)+ $(lift i) |] instance Lift FieldDef where lift (FieldDef a b c d) = [|FieldDef $(lift a) $(lift b) $(lift c) $(liftTs d)|]
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 0.9.0.2+version: 1.0.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -16,7 +16,7 @@ library build-depends: base >= 4 && < 5 , template-haskell- , persistent >= 0.9 && < 0.10+ , persistent >= 1.0 && < 1.1 , monad-control >= 0.2 && < 0.4 , text >= 0.5 && < 1.0 , transformers >= 0.2 && < 0.4