Permalink
Browse files

first stab at full support for embedded entities

  • Loading branch information...
1 parent 7ac1c6b commit 3aef283a7c23ccbd4183db89ba3f8d02e6f134e3 @gregwebs gregwebs committed Jan 29, 2012
Showing with 40 additions and 17 deletions.
  1. +30 −11 persistent-template/Database/Persist/TH.hs
  2. +10 −6 persistent-test/PersistentTest.hs
@@ -52,7 +52,7 @@ import qualified Data.Text as T
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
-- | Converts a quasi-quoted syntax into a list of entity definitions, to be
-- used as input to the template haskell generation code (mkPersist).
@@ -90,7 +90,16 @@ persistFile = persistFileWith upperCaseSettings
-- | 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 = fmap mconcat $ mapM (mkEntity mps entLookup) ents
+ where
+ entMap = M.fromList $ zip (map (unHaskellName . entityHaskell) ents) ents
+ entLookup fd =
+ let typName = unFieldType $ fieldType fd
+ in case M.lookup typName entMap of
+ Nothing -> lookupError typName
+ Just ent -> ent
+ lookupError field = error $ unpack $
+ "expected the schema to define " `mappend` field
-- | Settings to be passed to the 'mkPersist' function.
data MkPersistSettings = MkPersistSettings
@@ -299,15 +308,21 @@ mkFromPersistValues t = do
where
go ap' x y = InfixE (Just x) ap' (Just y)
-mkEntity :: MkPersistSettings -> EntityDef -> Q [Dec]
-mkEntity mps t = do
+
+mkEntity :: MkPersistSettings -> (FieldDef -> EntityDef) -> EntityDef -> Q [Dec]
+mkEntity mps entLookup t = do
t' <- lift t
let name = unpack $ unHaskellName $ entityHaskell t
let clazz = ConT ''PersistEntity `AppT` (ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix) `AppT` VarT (mkName "backend"))
tpf <- mkToPersistFields [(name, length $ entityFields t)]
fpv <- mkFromPersistValues t
utv <- mkUniqueToValues $ entityUniques t
puk <- mkUniqueKeys t
+
+ -- TODO: enforce ordering issue: embedded entities must be defined before they are later embedded
+ let embeddedFields = filter fieldEmbedded (entityFields t)
+ embeds <- fmap mconcat $ mapM persistFieldFromEntity $ map entLookup embeddedFields
+
fields <- mapM (mkField t) $ FieldDef
(HaskellName "Id")
(entityID t)
@@ -316,7 +331,7 @@ mkEntity mps t = do
False
: entityFields t
toFieldNames <- mkToFieldNames $ entityUniques t
- return $
+ return $ embeds `mappend`
[ dataTypeDec t
, TySynD (mkName $ unpack $ unHaskellName $ entityHaskell t) [] $
ConT (mkName $ unpack $ unHaskellName (entityHaskell t) ++ suffix)
@@ -369,9 +384,10 @@ persistFieldFromEntity e = do
fpv <- [|\x -> fromPersistValues $ map (\(_,v) -> case fromPersistValue v of
Left e' -> error $ unpack e'
Right r -> r) x|]
+
return
[ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName $ unpack $ unHaskellName $ entityHaskell e))
- [ FunD (mkName "sqlType") [ Clause [WildP] (NormalB ss) [] ]
+ [ sqlTypeFunD ss
, FunD (mkName "toPersistValue") [ Clause [] (NormalB obj) [] ]
, FunD (mkName "fromPersistValue")
[ Clause [ConP (mkName "PersistMap") [VarP pmName]]
@@ -516,6 +532,11 @@ mkUniqueKeys def = do
let Just col' = lookup col xs
in front `AppE` VarE col'
+sqlTypeFunD :: Exp -> Dec
+sqlTypeFunD st = FunD (mkName "sqlType")
+ [ Clause [WildP] (NormalB st) []
+ ]
+
-- | Automatically creates a valid 'PersistField' instance for any datatype
-- that has valid 'Show' and 'Read' instances. Can be very convenient for
-- 'Enum' types.
@@ -532,9 +553,7 @@ derivePersistField s = do
[] -> Left $ "Invalid " ++ dt ++ ": " ++ s'|]
return
[ InstanceD [] (ConT ''PersistField `AppT` ConT (mkName s))
- [ FunD (mkName "sqlType")
- [ Clause [WildP] (NormalB ss) []
- ]
+ [ sqlTypeFunD ss
, FunD (mkName "toPersistValue")
[ Clause [] (NormalB tpv) []
]
@@ -603,8 +622,8 @@ liftTs = fmap ListE . mapM liftT
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))|]
@@ -111,15 +111,19 @@ data PetType = Cat | Dog
derivePersistField "PetType"
#if WITH_MONGODB
-data Embedded = Embedded { embeddedName :: String, embeddedEmbed :: Embedded2 }
- deriving(Show, Read, Eq)
-data Embedded2 = Embedded2 { embedded2name :: String }
- deriving(Show, Read, Eq)
-
mkPersist MkPersistSettings { mpsBackend = ConT ''Action } [persistUpperCase|
+
+-- Embedded2 no-migrate
+-- embedded2name String
+
+ Embedded no-migrate
+ embeddedName String
+-- embeddedEmbed ^Embedded2
+
HasEmbed
name String
embed ^Embedded
+
#else
share [mkPersist sqlSettings, mkMigrate "testMigrate", mkDeleteCascade] [persistUpperCase|
#endif
@@ -381,7 +385,7 @@ specs = describe "persistent" $ do
#ifdef WITH_MONGODB
it "embedded entities" $ db $ do
- let container = HasEmbed "container" (Embedded "embedded" (Embedded2 "2"))
+ let container = HasEmbed "container" (Embedded "embedded") -- (Embedded2 "2"))
contK <- insert container
Just res <- selectFirst [HasEmbedName ==. "container"] []
res @== (Entity contK container)

0 comments on commit 3aef283

Please sign in to comment.