persistent-template 0.7.0 → 0.8.0
raw patch · 2 files changed
+180/−75 lines, 2 filesdep +HUnitdep +QuickCheckdep +aesondep ~persistentdep ~textPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, QuickCheck, aeson, bytestring, hspec, persistent-template
Dependency ranges changed: persistent, text
API changes (from Hackage documentation)
+ Database.Persist.TH: persistFieldFromEntity :: EntityDef -> Q [Dec]
Files
- Database/Persist/TH.hs +159/−72
- persistent-template.cabal +21/−3
Database/Persist/TH.hs view
@@ -23,6 +23,7 @@ , mkDeleteCascade , share , derivePersistField+ , persistFieldFromEntity -- ** Deprecated , share2 ) where@@ -38,7 +39,7 @@ import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Data.Char (toLower, toUpper)-import Control.Monad (forM)+import Control.Monad (forM, (<=<), mzero) #if MIN_VERSION_monad_control(0, 3, 0) import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO)@@ -46,12 +47,16 @@ import Control.Monad.IO.Control (MonadControlIO) #endif import qualified System.IO as SIO-import Data.Text (pack, Text, append, isSuffixOf, unpack, take, concat, uncons, cons, splitAt)-import qualified Data.Text as T+import Data.Text (pack, Text, append, unpack, concat, uncons, cons) import qualified Data.Text.IO as TIO import Data.List (foldl') import Data.Monoid (mappend, mconcat)-import qualified Data.Map as Map+import qualified Data.Map as M+import Data.Aeson+ ( ToJSON (toJSON), FromJSON (parseJSON), (.=), object+ , Value (Object), (.:), (.:?)+ )+import Control.Applicative (pure, (<*>)) -- | Converts a quasi-quoted syntax into a list of entity definitions, to be -- used as input to the template haskell generation code (mkPersist).@@ -77,6 +82,9 @@ -- quasiquotation. persistFileWith :: PersistSettings -> FilePath -> Q Exp persistFileWith ps fp = do+#ifdef GHC_7_4+ qAddDependentFile fp+#endif h <- qRunIO $ SIO.openFile fp SIO.ReadMode qRunIO $ SIO.hSetEncoding h SIO.utf8_bom s <- qRunIO $ TIO.hGetContents h@@ -89,7 +97,11 @@ -- | Create data types and appropriate 'PersistEntity' instances for the given -- 'EntityDef's. Works well with the persist quasi-quoter. mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]-mkPersist mps = fmap mconcat . mapM (mkEntity mps)+mkPersist mps ents = do+ x <- fmap mconcat $ mapM persistFieldFromEntity ents+ y <- fmap mconcat $ mapM (mkEntity mps) ents+ z <- fmap mconcat $ mapM mkJSON ents+ return $ mconcat [x, y, z] -- | Settings to be passed to the 'mkPersist' function. data MkPersistSettings = MkPersistSettings@@ -124,13 +136,15 @@ dataTypeDec :: EntityDef -> Dec dataTypeDec t =- DataD [] nameG [PlainTV backend] [RecC name cols]+ DataD [] nameG [KindedTV backend monadTransKind] [RecC name cols] $ map (mkName . unpack) $ entityDerives t where+ monadKind = StarK `ArrowK` StarK+ monadTransKind = monadKind `ArrowK` monadKind mkCol x (FieldDef n _ ty as) = (mkName $ unpack $ recName x $ unHaskellName n, NotStrict,- pairToType backend (unFieldType ty, nullable as)+ pairToType backend (ty, nullable as) ) nameG = mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix name = mkName $ unpack $ unHaskellName $ entityHaskell t@@ -170,7 +184,7 @@ go :: (FieldType, Bool) -> (Strict, Type) go (_, True) = error "Error: cannot have nullables in unique"- go (FieldType x, y) = (NotStrict, pairToType backend (x, y))+ go (ft, y) = (NotStrict, pairToType backend (ft, y)) lookup3 :: Text -> [FieldDef] -> (FieldType, Bool) lookup3 s [] =@@ -180,18 +194,19 @@ | otherwise = lookup3 x rest pairToType :: Name -- ^ backend- -> (Text, Bool) -> Type+ -> (FieldType, Bool) -- ^ True == has Maybe attr+ -> Type pairToType backend (s, False) = idType backend s pairToType backend (s, True) = ConT (mkName "Maybe") `AppT` idType backend s -idType :: Name -> Text -> Type-idType backend typ- | "Id" `isSuffixOf` typ =- ConT ''Key- `AppT` VarT backend- `AppT` (ConT (mkName $ unpack $ take (T.length typ - 2) typ ++ "Generic")- `AppT` VarT backend)- | otherwise = ConT $ mkName $ unpack typ+idType :: Name -> FieldType -> Type+idType backend typ =+ case stripId typ of+ Just typ' ->+ ConT ''Key+ `AppT` VarT backend+ `AppT` (ConT (mkName $ unpack $ typ' ++ "Generic") `AppT` VarT backend)+ Nothing -> ftToType typ degen :: [Clause] -> [Clause] degen [] =@@ -296,41 +311,46 @@ where go ap' x y = InfixE (Just x) ap' (Just y) + mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec] mkEntity mps t = do t' <- lift t- let name = unpack $ unHaskellName $ entityHaskell t+ 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 [(name, length $ entityFields t)]+ tpf <- mkToPersistFields [(nameS, length $ entityFields t)] fpv <- mkFromPersistValues t utv <- mkUniqueToValues $ entityUniques t puk <- mkUniqueKeys t+ fields <- mapM (mkField t) $ FieldDef (HaskellName "Id") (entityID t)- (FieldType $ unHaskellName (entityHaskell t) ++ "Id") []+ (FTTypeCon Nothing $ unHaskellName (entityHaskell t) ++ "Id")+ [] : entityFields t toFieldNames <- mkToFieldNames $ entityUniques t- return $++ return [ dataTypeDec t- , TySynD (mkName $ unpack $ unHaskellName $ entityHaskell t) [] $- ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix)+ , TySynD (mkName nameS) [] $+ ConT (mkName $ unpack $ nameT ++ suffix) `AppT` mpsBackend mps , TySynD (mkName $ unpack $ unHaskellName (entityHaskell t) ++ "Id") [] $- ConT ''Key `AppT` mpsBackend mps `AppT` ConT (mkName $ unpack $ unHaskellName $ entityHaskell t)+ ConT ''Key `AppT` mpsBackend mps `AppT` ConT (mkName nameS) , InstanceD [] clazz $ [ uniqueTypeDec t , FunD (mkName "entityDef") [Clause [WildP] (NormalB t') []] , tpf , FunD (mkName "fromPersistValues") fpv- , mkHalfDefined name $ length $ entityFields t+ , mkHalfDefined nameS $ length $ entityFields t , toFieldNames , utv , puk , DataInstD [] ''EntityField- [ ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend")+ [ ConT (mkName $ unpack $ nameT ++ suffix) `AppT` VarT (mkName "backend") , VarT $ mkName "typ" ] (map fst fields)@@ -344,7 +364,8 @@ ] ] --- | produce code similar to the following+-- | produce code similar to the following:+-- -- instance PersistEntity e => PersistField e where -- toPersistValue = PersistMap $ zip columNames (map toPersistValue . toPersistFields) -- fromPersistValue (PersistMap o) = fromPersistValues $ map (\(_,v) ->@@ -356,24 +377,27 @@ persistFieldFromEntity :: EntityDef -> Q [Dec] persistFieldFromEntity e = do ss <- [|SqlString|]- unexpected <- [|\x -> Left $ "Expected PersistMap, received: " ++ T.pack (show x)|] let columnNames = map (unpack . unHaskellName . fieldHaskell) (entityFields e)- obj <- [|PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields e)|]- pmName <- newName "pm"+ obj <- [|\ent -> PersistMap $ zip (map pack columnNames) (map toPersistValue $ toPersistFields ent)|] fpv <- [|\x -> fromPersistValues $ map (\(_,v) -> case fromPersistValue v of Left e' -> error $ unpack e' Right r -> r) x|]+ let typ = ConT (mkName $ entityName `mappend` "Generic")+ `AppT` VarT (mkName "backend")++ compose <- [|(<=<)|]+ getPersistMap' <- [|getPersistMap|] return- [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName $ unpack $ unHaskellName $ entityHaskell e))- [ FunD (mkName "sqlType") [ Clause [WildP] (NormalB ss) [] ]+ [ persistFieldInstanceD typ+ [ sqlTypeFunD ss , FunD (mkName "toPersistValue") [ Clause [] (NormalB obj) [] ] , FunD (mkName "fromPersistValue")- [ Clause [ConP (mkName "PersistMap") [VarP pmName]]- (NormalB $ fpv `AppE` VarE pmName) []- , Clause [WildP] (NormalB unexpected) []+ [ Clause [] (NormalB $ InfixE (Just fpv) compose $ Just getPersistMap') [] ] ] ]+ where+ entityName = (unpack $ unHaskellName $ entityHaskell e) updateConName :: Text -> Text -> PersistUpdate -> Text updateConName name s pu = concat@@ -432,17 +456,15 @@ getDeps' :: FieldDef -> [Dep] getDeps' (FieldDef name _ ftyp attribs) = let isNull = nullable attribs- typ = unFieldType ftyp- l = T.length typ- (f, b) = splitAt (l - 2) typ- in if b == "Id"- then return Dep+ in case stripId ftyp of+ Just f ->+ return Dep { depTarget = f , depSourceTable = entityHaskell def , depSourceField = name , depSourceNull = isNull }- else []+ Nothing -> [] go :: [Dep] -> EntityDef -> Q Dec go allDeps EntityDef{entityHaskell = name} = do let deps = filter (\x -> depTarget x == unHaskellName name) allDeps@@ -510,6 +532,14 @@ let Just col' = lookup col xs in front `AppE` VarE col' +sqlTypeFunD :: Exp -> Dec+sqlTypeFunD st = FunD (mkName "sqlType")+ [ Clause [WildP] (NormalB st) [] ]++persistFieldInstanceD :: Type -> [Dec] -> Dec+persistFieldInstanceD typ =+ InstanceD [] (ConT ''PersistField `AppT` typ)+ -- | Automatically creates a valid 'PersistField' instance for any datatype -- that has valid 'Show' and 'Read' instances. Can be very convenient for -- 'Enum' types.@@ -525,10 +555,8 @@ (x, _):_ -> Right x [] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|] return- [ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s))- [ FunD (mkName "sqlType")- [ Clause [WildP] (NormalB ss) []- ]+ [ persistFieldInstanceD (ConT $ mkName s)+ [ sqlTypeFunD ss , FunD (mkName "toPersistValue") [ Clause [] (NormalB tpv) [] ]@@ -543,22 +571,19 @@ -- with foreign references, make sure to place those definitions after the -- entities they reference. mkMigrate :: String -> [EntityDef] -> Q [Dec]-mkMigrate fun defs = do+mkMigrate fun allDefs = do body' <- body return [ SigD (mkName fun) typ , FunD (mkName fun) [Clause [] (NormalB body') []] ] where+ defs = filter isMigrated allDefs+ isMigrated def = not $ "no-migrate" `elem` entityAttrs def typ = ForallT [PlainTV $ mkName "m"]-#if MIN_VERSION_monad_control(0, 3, 0) [ ClassP ''MonadBaseControl [ConT ''IO, VarT $ mkName "m"] , ClassP ''MonadIO [VarT $ mkName "m"] ]-#else- [ ClassP ''MonadControlIO [VarT $ mkName "m"]- ]-#endif $ ConT ''Migration `AppT` (ConT ''SqlPersist `AppT` VarT (mkName "m")) body :: Q Exp body =@@ -600,8 +625,8 @@ liftTss :: [[Text]] -> Q Exp liftTss = fmap ListE . mapM liftTs -liftMap :: Map.Map Text [[Text]] -> Q Exp-liftMap m = [|Map.fromList $(fmap ListE $ mapM liftPair $ Map.toList m)|]+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))|]@@ -611,7 +636,10 @@ instance Lift DBName where lift (DBName t) = [|DBName $(liftT t)|] instance Lift FieldType where- lift (FieldType t) = [|FieldType $(liftT t)|]+ lift (FTTypeCon Nothing t) = [|FTTypeCon Nothing $(liftT t)|]+ lift (FTTypeCon (Just x) t) = [|FTTypeCon (Just $(liftT x)) $(liftT t)|]+ lift (FTApp x y) = [|FTApp $(lift x) $(lift y)|]+ lift (FTList x) = [|FTList $(lift x)|] instance Lift PersistFilter where lift Eq = [|Eq|]@@ -631,11 +659,17 @@ lift Multiply = [|Multiply|] lift Divide = [|Divide|] +-- Ent+-- fieldName FieldType+--+-- forall . typ ~ FieldType => EntFieldName+--+-- EntFieldName = FieldDef .... mkField :: EntityDef -> FieldDef -> Q (Con, Clause) mkField et cd = do let con = ForallC []- [EqualP (VarT $ mkName "typ") typ]+ [EqualP (VarT $ mkName "typ") maybeTyp] $ NormalC name [] bod <- lift cd let cla = Clause@@ -643,35 +677,88 @@ (NormalB bod) [] return (con, cla)- {-- bod <- [|Field $(lift cd)|]- return- [ SigD name $ ConT ''Field `AppT` ConT (mkName $ entityHaskell et) `AppT` typ- , FunD name [Clause [] (NormalB bod) []]- ]- -} where name = mkName $ unpack $ concat [ unHaskellName $ entityHaskell et , upperFirst $ unHaskellName $ fieldHaskell cd ]- base =- if "Id" `isSuffixOf` unFieldType (fieldType cd)- then ConT ''Key+ maybeTyp =+ if nullable $ fieldAttrs cd+ then ConT ''Maybe `AppT` typ+ else typ+ typ =+ case stripId $ fieldType cd of+ Just ft ->+ ConT ''Key `AppT` (VarT $ mkName "backend") `AppT`- let len = T.length (unFieldType $ fieldType cd) - 2- ft = take len $ unFieldType $ fieldType cd- con = ConT $ mkName $ unpack $ ft ++ suffix+ let con = ConT $ mkName $ unpack $ ft ++ suffix in con `AppT` VarT (mkName "backend")- else ConT $ mkName $ unpack $ unFieldType $ fieldType cd- typ = if nullable $ fieldAttrs cd- then ConT ''Maybe `AppT` base- else base+ Nothing -> ftToType $ fieldType cd +ftToType :: FieldType -> Type+ftToType (FTTypeCon Nothing t) = ConT $ mkName $ unpack t+ftToType (FTTypeCon (Just m) t) = ConT $ mkName $ unpack $ concat [m, ".", t]+ftToType (FTApp x y) = ftToType x `AppT` ftToType y+ftToType (FTList x) = ListT `AppT` ftToType x+ suffix :: Text suffix = "Generic" infixr 5 ++ (++) :: Text -> Text -> Text (++) = append++mkJSON :: EntityDef -> Q [Dec]+mkJSON def | not ("json" `elem` entityAttrs def) = return []+mkJSON def = do+ pureE <- [|pure|]+ apE' <- [|(<*>)|]+ packE <- [|pack|]+ dotEqualE <- [|(.=)|]+ dotColonE <- [|(.:)|]+ dotColonQE <- [|(.:?)|]+ objectE <- [|object|]+ obj <- newName "obj"+ mzeroE <- [|mzero|]++ xs <- mapM (newName . unpack . unHaskellName . fieldHaskell)+ $ entityFields def++ let con = ConT $ mkName $ unpack+ (unHaskellName (entityHaskell def) ++ "Generic")+ conName = mkName $ unpack $ unHaskellName $ entityHaskell def+ typ = con `AppT` VarT (mkName "backend")+ toJSONI = InstanceD+ []+ (ConT ''ToJSON `AppT` typ)+ [toJSON']+ toJSON' = FunD 'toJSON $ return $ Clause+ [ConP conName $ map VarP xs]+ (NormalB $ objectE `AppE` ListE pairs)+ []+ pairs = zipWith toPair (entityFields def) xs+ toPair f x = InfixE+ (Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f)))+ dotEqualE+ (Just $ VarE x)+ fromJSONI = InstanceD+ []+ (ConT ''FromJSON `AppT` typ)+ [parseJSON']+ parseJSON' = FunD 'parseJSON+ [ Clause [ConP 'Object [VarP obj]]+ (NormalB $ foldl'+ (\x y -> InfixE (Just x) apE' (Just y))+ (pureE `AppE` ConE conName)+ pulls+ )+ []+ , Clause [WildP] (NormalB mzeroE) []+ ]+ pulls = map toPull $ entityFields def+ toPull f = InfixE+ (Just $ VarE obj)+ (if nullable (fieldAttrs f) then dotColonQE else dotColonE)+ (Just $ AppE packE $ LitE $ StringL $ unpack $ unHaskellName $ fieldHaskell f)+ return [toJSONI, fromJSONI]
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 0.7.0+version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,20 +8,38 @@ description: This library provides just the general interface and helper functions. You must use a specific backend in order to make this useful. category: Database, Yesod stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent library build-depends: base >= 4 && < 5 , template-haskell- , persistent >= 0.7 && < 0.8+ , persistent >= 0.8 && < 0.9 , monad-control >= 0.2 && < 0.4 , text >= 0.5 && < 1.0 , transformers >= 0.2 , containers+ , aeson exposed-modules: Database.Persist.TH ghc-options: -Wall+ if impl(ghc >= 7.4)+ cpp-options: -DGHC_7_4++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test++ build-depends: base >= 4 && < 5+ , persistent-template+ , aeson+ , hspec+ , text+ , persistent+ , bytestring+ , HUnit+ , QuickCheck source-repository head type: git