persistent-template 2.1.3 → 2.1.3.1
raw patch · 3 files changed
+80/−43 lines, 3 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Database.Persist.TH: instance [overlap ok] Show FTTypeConDescr
Files
- ChangeLog.md +4/−0
- Database/Persist/TH.hs +75/−42
- persistent-template.cabal +1/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 2.1.3.1++Support foreign key references to composite primary keys+ ## 2.1.0.1 Support for monad-control 1.0
Database/Persist/TH.hs view
@@ -105,14 +105,16 @@ -- afterwards, sets references to other entities parseReferences :: PersistSettings -> Text -> Q Exp parseReferences ps s = lift $- map (mkEntityDefSqlTypeExp entityMap . breakCycleEnt) entsWithEmbeds+ map (mkEntityDefSqlTypeExp embedEntityMap entMap) noCycleEnts where+ entMap = M.fromList $ map (\ent -> (entityHaskell ent, ent)) noCycleEnts+ noCycleEnts = map breakCycleEnt entsWithEmbeds -- every EntityDef could reference each-other (as an EmbedRef) -- let Haskell tie the knot- entityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds+ embedEntityMap = M.fromList $ map (\ent -> (entityHaskell ent, toEmbedEntityDef ent)) entsWithEmbeds entsWithEmbeds = map setEmbedEntity rawEnts setEmbedEntity ent = ent- { entityFields = map (setEmbedField (entityHaskell ent) entityMap) $ entityFields ent+ { entityFields = map (setEmbedField (entityHaskell ent) embedEntityMap) $ entityFields ent } rawEnts = parse ps s @@ -203,28 +205,36 @@ instance Lift EmbedFieldDef where lift (EmbedFieldDef name em cyc) = [|EmbedFieldDef name em cyc|] -type EntityMap = M.Map HaskellName EmbedEntityDef-mEmbedded :: EntityMap -> FieldType -> Maybe EmbedEntityDef-mEmbedded _ (FTTypeCon Just{} _) = Nothing+type EmbedEntityMap = M.Map HaskellName EmbedEntityDef+type EntityMap = M.Map HaskellName EntityDef++data FTTypeConDescr = FTKeyCon deriving Show+mEmbedded :: EmbedEntityMap -> FieldType -> Either (Maybe FTTypeConDescr) EmbedEntityDef+mEmbedded _ (FTTypeCon Just{} _) = Left Nothing mEmbedded ents (FTTypeCon Nothing n) = let name = HaskellName n in- M.lookup name ents+ maybe (Left Nothing) Right $ M.lookup name ents mEmbedded ents (FTList x) = mEmbedded ents x-mEmbedded ents (FTApp x y) = maybe (mEmbedded ents y) Just (mEmbedded ents x)+mEmbedded ents (FTApp x y) =+ -- Key convets an Record to a RecordId+ -- special casing this is obviously a hack+ -- This problem may not be solvable with the current QuasiQuoted approach though+ if x == FTTypeCon Nothing "Key"+ then Left $ Just FTKeyCon+ else mEmbedded ents y -setEmbedField :: HaskellName -> EntityMap -> FieldDef -> FieldDef+setEmbedField :: HaskellName -> EmbedEntityMap -> FieldDef -> FieldDef setEmbedField entName allEntities field = field { fieldReference = case fieldReference field of NoReference -> case mEmbedded allEntities (fieldType field) of- Nothing -> case stripId $ fieldType field of+ Left _ -> case stripId $ fieldType field of Nothing -> NoReference- Just name -> if M.member (HaskellName name) allEntities- then ForeignRef (HaskellName name)- -- the EmebedEntityDef does not contain FieldType information- -- but we shouldn't need this anyway+ Just name -> case M.lookup (HaskellName name) allEntities of+ Nothing -> NoReference+ Just x -> ForeignRef (HaskellName name)+ -- This will get corrected in mkEntityDefSqlTypeExp (FTTypeCon Nothing $ pack $ nameBase ''Int)- else NoReference- Just em -> if embeddedHaskell em /= entName+ Right em -> if embeddedHaskell em /= entName then EmbedRef em else if maybeNullable field then SelfReference@@ -232,8 +242,8 @@ existing@_ -> existing } -mkEntityDefSqlTypeExp :: EntityMap -> EntityDef -> EntityDefSqlTypeExp-mkEntityDefSqlTypeExp allEntities ent = EntityDefSqlTypeExp ent+mkEntityDefSqlTypeExp :: EmbedEntityMap -> EntityMap -> EntityDef -> EntityDefSqlTypeExp+mkEntityDefSqlTypeExp emEntities entMap ent = EntityDefSqlTypeExp ent (getSqlType $ entityId ent) $ (map getSqlType $ entityFields ent) where@@ -245,10 +255,20 @@ -- In the case of embedding, there won't be any datatype created yet. -- We just use SqlString, as the data will be serialized to JSON.- defaultSqlTypeExp field- | isJust (mEmbedded allEntities ftype) = SqlType' SqlString- | otherwise = case fieldReference field of- ForeignRef _ ft -> SqlTypeExp ft+ defaultSqlTypeExp field = case mEmbedded emEntities ftype of+ Right _ -> SqlType' SqlString+ Left (Just FTKeyCon) -> SqlType' SqlString+ Left Nothing -> case fieldReference field of+ ForeignRef refName ft -> case M.lookup refName entMap of+ Nothing -> SqlTypeExp ft+ -- A ForeignRef is blindly set to an Int in setEmbedField+ -- correct that now+ Just ent -> case entityPrimary ent of+ Nothing -> SqlTypeExp ft+ Just pdef -> case compositeFields pdef of+ [] -> error "mkEntityDefSqlTypeExp: no composite fields"+ [x] -> SqlTypeExp $ fieldType x+ _ -> SqlType' $ SqlOther "Composite Reference" CompositeRef _ -> SqlType' $ SqlOther "Composite Reference" _ -> case ftype of -- In the case of lists, we always serialize to a string@@ -676,7 +696,7 @@ where keyConE = keyConExp t unKeyE = unKeyExp t- dec = RecC (keyConName t) keyFields+ dec = RecC (keyConName t) (keyFields mps t) k = ''Key recordType = genericDataType mps (entityHaskell t) backendT pfInstD = -- FIXME: generate a PersistMap instead of PersistList@@ -748,22 +768,10 @@ else fmap (alwaysInstances `mappend`) backendKeyGenericI return instances - useNewtype = length keyFields < 2- defaultIdType = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)- keyFields = case entityPrimary t of- Just pdef -> map primaryKeyVar $ (compositeFields pdef)- Nothing -> if defaultIdType- then [idKeyVar backendKeyType]- else [idKeyVar $ ftToType $ fieldType $ entityId t]- customKeyType = not defaultIdType || not useNewtype || isJust (entityPrimary t)+ useNewtype = pkNewtype mps t+ customKeyType = not (defaultIdType t) || not useNewtype || isJust (entityPrimary t) - primaryKeyVar fd = (keyFieldName t fd, NotStrict, ftToType $ fieldType fd)- idKeyVar ft = (unKeyName t, NotStrict, ft) - backendKeyType- | mpsGeneric mps = ConT ''BackendKey `AppT` backendT- | otherwise = ConT ''BackendKey `AppT` mpsBackend mps- keyIdName :: EntityDef -> Name keyIdName = mkName . unpack . keyIdText @@ -797,11 +805,36 @@ keyText :: EntityDef -> Text keyText t = unHaskellName (entityHaskell t) ++ "Key" -keyFieldName :: EntityDef -> FieldDef -> Name-keyFieldName t fd = mkName $ unpack $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)+pkNewtype :: MkPersistSettings -> EntityDef -> Bool+pkNewtype mps t = length (keyFields mps t) < 2 +defaultIdType :: EntityDef -> Bool+defaultIdType t = fieldType (entityId t) == FTTypeCon Nothing (keyIdText t)++keyFields :: MkPersistSettings -> EntityDef -> [(Name, Strict, Type)]+keyFields mps t = case entityPrimary t of+ Just pdef -> map primaryKeyVar $ (compositeFields pdef)+ Nothing -> if defaultIdType t+ then [idKeyVar backendKeyType]+ else [idKeyVar $ ftToType $ fieldType $ entityId t]+ where+ backendKeyType+ | mpsGeneric mps = ConT ''BackendKey `AppT` backendT+ | otherwise = ConT ''BackendKey `AppT` mpsBackend mps+ idKeyVar ft = (unKeyName t, NotStrict, ft)+ primaryKeyVar fd = ( keyFieldName mps t fd+ , NotStrict+ , ftToType $ fieldType fd+ )++keyFieldName :: MkPersistSettings -> EntityDef -> FieldDef -> Name+keyFieldName mps t fd+ | pkNewtype mps t = unKeyName t+ | otherwise = mkName $ unpack+ $ lowerFirst (keyText t) `mappend` (unHaskellName $ fieldHaskell fd)+ mkKeyToValues :: MkPersistSettings -> EntityDef -> Q Dec-mkKeyToValues _mps t = do+mkKeyToValues mps t = do (p, e) <- case entityPrimary t of Nothing -> ([],) <$> [|(:[]) . toPersistValue . $(return $ unKeyExp t)|]@@ -811,7 +844,7 @@ where toValuesPrimary pdef = ( [VarP recordName]- , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName t fd) `AppE` VarE recordName)) $ compositeFields pdef+ , ListE $ map (\fd -> VarE 'toPersistValue `AppE` (VarE (keyFieldName mps t fd) `AppE` VarE recordName)) $ compositeFields pdef ) recordName = mkName "record" @@ -872,7 +905,7 @@ t' <- lift t let nameT = unHaskellName entName let nameS = unpack nameT- let clazz = ConT ''PersistEntity `AppT` genericDataType mps entName backendT+ let clazz = ConT ''PersistEntity `AppT` genDataType tpf <- mkToPersistFields mps nameS t fpv <- mkFromPersistValues mps t utv <- mkUniqueToValues $ entityUniques t
persistent-template.cabal view
@@ -1,5 +1,5 @@ name: persistent-template-version: 2.1.3+version: 2.1.3.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>