Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Refactor entity constraint parsing in Quasi module #1315

Merged
Prev Previous commit
Next Next commit
Explicit error functions
danbroooks committed Jan 29, 2022
commit bedd35383da8c55c4abf3cfcf23ea81cce0e07f2
15 changes: 10 additions & 5 deletions persistent/Database/Persist/Quasi/Internal.hs
Original file line number Diff line number Diff line change
@@ -927,16 +927,21 @@ data EntityConstraintDefs = EntityConstraintDefs
instance Semigroup EntityConstraintDefs where
a <> b =
EntityConstraintDefs
{ entityConstraintDefsIdField = just1 (entityConstraintDefsIdField a) (entityConstraintDefsIdField b)
, entityConstraintDefsPrimaryComposite = just1 (entityConstraintDefsPrimaryComposite a) (entityConstraintDefsPrimaryComposite b)
{ entityConstraintDefsIdField = justOneId (entityConstraintDefsIdField a) (entityConstraintDefsIdField b)
, entityConstraintDefsPrimaryComposite = justOneComposite (entityConstraintDefsPrimaryComposite a) (entityConstraintDefsPrimaryComposite b)
, entityConstraintDefsUniques = entityConstraintDefsUniques a <> entityConstraintDefsUniques b
, entityConstraintDefsForeigns = entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b
}

just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x
just1 (Just x) (Just y) = error $ "expected only one of: "
justOneId :: Maybe UnboundIdDef -> Maybe UnboundIdDef -> Maybe UnboundIdDef
justOneId (Just x) (Just y) = error $ "expected only one of: "
`mappend` show x `mappend` " " `mappend` show y
just1 x y = x `mplus` y
justOneId x y = x `mplus` y

justOneComposite :: Maybe UnboundCompositeDef -> Maybe UnboundCompositeDef -> Maybe UnboundCompositeDef
justOneComposite (Just x) (Just y) = error $ "expected only one of: "
`mappend` show x `mappend` " " `mappend` show y
justOneComposite x y = x `mplus` y

instance Monoid EntityConstraintDefs where
mempty =