diff --git a/Database/Persist/TH.hs b/Database/Persist/TH.hs --- a/Database/Persist/TH.hs +++ b/Database/Persist/TH.hs @@ -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] diff --git a/persistent-template.cabal b/persistent-template.cabal --- a/persistent-template.cabal +++ b/persistent-template.cabal @@ -1,5 +1,5 @@ name: persistent-template -version: 0.7.0 +version: 0.8.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -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