From 96aa918600023a49209b28ccedc79832cec28d10 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 7 Sep 2021 17:30:20 +0100 Subject: [PATCH 1/9] Refactor to semigroup type --- persistent/Database/Persist/Quasi/Internal.hs | 110 ++++++++++++------ 1 file changed, 73 insertions(+), 37 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index ca02e73f4..478dfffd0 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -58,7 +58,7 @@ import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Monoid (mappend) import Data.Text (Text) import qualified Data.Text as T @@ -636,7 +636,7 @@ mkUnboundEntityDef mkUnboundEntityDef ps parsedEntDef = UnboundEntityDef { unboundForeignDefs = - foreigns + entityConstraintDefsForeignsList entityConstraintDefs , unboundPrimarySpec = case (idField, primaryComposite) of (Just {}, Just {}) -> @@ -667,7 +667,7 @@ mkUnboundEntityDef ps parsedEntDef = parsedEntityDefEntityAttributes parsedEntDef , entityFields = [] - , entityUniques = uniqs + , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs , entityForeigns = [] , entityDerives = concat $ mapMaybe takeDerives textAttribs , entityExtra = parsedEntityDefExtras parsedEntDef @@ -689,17 +689,14 @@ mkUnboundEntityDef ps parsedEntDef = textAttribs = fmap tokenText <$> attribs - (idField, primaryComposite, uniqs, foreigns) = - foldl' - (\(mid, mp, us, fs) attr -> - let - (i, p, u, f) = takeConstraint ps entNameHS cols attr - squish xs m = xs `mappend` maybeToList m - in - (just1 mid i, just1 mp p, squish us u, squish fs f) - ) - (Nothing, Nothing, [],[]) - textAttribs + entityConstraintDefs = + foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs + + idField = + entityConstraintDefsIdField entityConstraintDefs + + primaryComposite = + entityConstraintDefsPrimaryComposite entityConstraintDefs cols :: [UnboundFieldDef] cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs @@ -801,11 +798,6 @@ setFieldComments xs fld = [] -> fld _ -> fld { unboundFieldComments = Just (T.unlines xs) } -just1 :: (Show x) => Maybe x -> Maybe x -> Maybe x -just1 (Just x) (Just y) = error $ "expected only one of: " - `mappend` show x `mappend` " " `mappend` show y -just1 x y = x `mplus` y - mkAutoIdField :: PersistSettings -> EntityNameHS -> SqlType -> FieldDef mkAutoIdField ps = mkAutoIdField' (FieldNameDB $ psIdName ps) @@ -928,28 +920,72 @@ getSqlNameOr def = _ -> Nothing +data EntityConstraintDefs = EntityConstraintDefs + { entityConstraintDefsIdField :: Maybe UnboundIdDef + , entityConstraintDefsPrimaryComposite :: Maybe UnboundCompositeDef + , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef) + , entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef) + } + +instance Semigroup EntityConstraintDefs where + a <> b = + EntityConstraintDefs + { entityConstraintDefsIdField = just1 (entityConstraintDefsIdField a) (entityConstraintDefsIdField b) + , entityConstraintDefsPrimaryComposite = just1 (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: " + `mappend` show x `mappend` " " `mappend` show y +just1 x y = x `mplus` y + +instance Monoid EntityConstraintDefs where + mempty = + EntityConstraintDefs Nothing Nothing Nothing Nothing + +entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef] +entityConstraintDefsUniquesList = foldMap NEL.toList . entityConstraintDefsUniques + +entityConstraintDefsForeignsList :: EntityConstraintDefs -> [UnboundForeignDef] +entityConstraintDefsForeignsList = foldMap NEL.toList . entityConstraintDefsForeigns + takeConstraint :: PersistSettings -> EntityNameHS -> [UnboundFieldDef] - -> [Text] - -> (Maybe UnboundIdDef, Maybe UnboundCompositeDef, Maybe UniqueDef, Maybe UnboundForeignDef) -takeConstraint ps entityName defs (n:rest) | isCapitalizedText n = takeConstraint' - where - takeConstraint' - | n == "Unique" = - (Nothing, Nothing, takeUniq ps (unEntityNameHS entityName) defs rest, Nothing) - | n == "Foreign" = - (Nothing, Nothing, Nothing, Just $ takeForeign ps entityName rest) - | n == "Primary" = - (Nothing, Just $ takeComposite defNames rest, Nothing, Nothing) - | n == "Id" = - (Just $ takeId ps entityName rest, Nothing, Nothing, Nothing) - | otherwise = - (Nothing, Nothing, takeUniq ps "" defs (n:rest), Nothing) -- retain compatibility with original unique constraint - defNames = - map unboundFieldNameHS defs -takeConstraint _ _ _ _ = (Nothing, Nothing, Nothing, Nothing) + -> NonEmpty Text + -> EntityConstraintDefs +takeConstraint ps entityName defs (n :| rest) = + case n of + "Unique" -> + mempty + { entityConstraintDefsUniques = + pure <$> takeUniq ps (unEntityNameHS entityName) defs rest + } + "Foreign" -> + mempty + { entityConstraintDefsForeigns = + Just $ pure (takeForeign ps entityName rest) + } + "Primary" -> + mempty + { entityConstraintDefsPrimaryComposite = + Just (takeComposite (unboundFieldNameHS <$> defs) rest) + } + "Id" -> + mempty + { entityConstraintDefsIdField = + Just (takeId ps entityName rest) + } + _ | isCapitalizedText n -> + mempty + { entityConstraintDefsUniques = + pure <$> takeUniq ps "" defs (n : rest) + } + _ -> + mempty -- | This type represents an @Id@ declaration in the QuasiQuoted syntax. -- From 76a916f3bba3c15d8aa9b368f7a7787206f2f186 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 7 Sep 2021 17:53:11 +0100 Subject: [PATCH 2/9] Rename splitExtras --- persistent/Database/Persist/Quasi/Internal.hs | 12 ++++++------ persistent/test/Database/Persist/QuasiSpec.hs | 12 ++++++------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 478dfffd0..c71a1d55b 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -26,7 +26,7 @@ module Database.Persist.Quasi.Internal , parseFieldType , associateLines , LinesWithComments(..) - , splitExtras + , parseEntityFields , takeColsEx -- * UnboundEntityDef , UnboundEntityDef(..) @@ -311,7 +311,7 @@ toParsedEntityDef lwc = ParsedEntityDef _ -> (False, EntityNameHS entityName) (attribs, extras) = - splitExtras fieldLines + parseEntityFields fieldLines isDocComment :: Token -> Maybe Text isDocComment tok = @@ -825,12 +825,12 @@ mkAutoIdField' dbName entName idSqlType = keyConName :: EntityNameHS -> Text keyConName entName = unEntityNameHS entName `mappend` "Id" -splitExtras +parseEntityFields :: [Line] -> ( [[Token]] , M.Map Text [ExtraLine] ) -splitExtras lns = +parseEntityFields lns = case lns of [] -> ([], M.empty) (line : rest) -> @@ -839,10 +839,10 @@ splitExtras lns = | isCapitalizedText name -> let indent = lineIndent line (children, rest') = span ((> indent) . lineIndent) rest - (x, y) = splitExtras rest' + (x, y) = parseEntityFields rest' in (x, M.insert name (NEL.toList . lineText <$> children) y) ts -> - let (x, y) = splitExtras rest + let (x, y) = parseEntityFields rest in (ts:x, y) isCapitalizedText :: Text -> Bool diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index c0320cd41..8a7d45e2e 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -23,28 +23,28 @@ import Text.Shakespeare.Text (st) spec :: Spec spec = describe "Quasi" $ do - describe "splitExtras" $ do + describe "parseEntityFields" $ do let helloWorldTokens = Token "hello" :| [Token "world"] foobarbazTokens = Token "foo" :| [Token "bar", Token "baz"] it "works" $ do - splitExtras [] + parseEntityFields [] `shouldBe` mempty it "works2" $ do - splitExtras + parseEntityFields [ Line 0 helloWorldTokens ] `shouldBe` ( [NEL.toList helloWorldTokens], mempty ) it "works3" $ do - splitExtras + parseEntityFields [ Line 0 helloWorldTokens , Line 2 foobarbazTokens ] `shouldBe` ( [NEL.toList helloWorldTokens, NEL.toList foobarbazTokens], mempty ) it "works4" $ do - splitExtras + parseEntityFields [ Line 0 [Token "Product"] , Line 2 (Token <$> ["name", "Text"]) , Line 2 (Token <$> ["added", "UTCTime", "default=CURRENT_TIMESTAMP"]) @@ -59,7 +59,7 @@ spec = describe "Quasi" $ do ) ] ) it "works5" $ do - splitExtras + parseEntityFields [ Line 0 [Token "Product"] , Line 2 (Token <$> ["name", "Text"]) , Line 4 [Token "ExtraBlock"] From 3547d1e232fe694eaf6229e1ee37ed45a5dd4f3d Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 7 Sep 2021 17:56:02 +0100 Subject: [PATCH 3/9] Extract function --- persistent/Database/Persist/Quasi/Internal.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index c71a1d55b..63b393452 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -827,9 +827,7 @@ keyConName entName = unEntityNameHS entName `mappend` "Id" parseEntityFields :: [Line] - -> ( [[Token]] - , M.Map Text [ExtraLine] - ) + -> ([[Token]], M.Map Text [ExtraLine]) parseEntityFields lns = case lns of [] -> ([], M.empty) @@ -837,14 +835,21 @@ parseEntityFields lns = case NEL.toList (tokens line) of [Token name] | isCapitalizedText name -> - let indent = lineIndent line - (children, rest') = span ((> indent) . lineIndent) rest - (x, y) = parseEntityFields rest' - in (x, M.insert name (NEL.toList . lineText <$> children) y) + parseExtraBlock name (line :| rest) ts -> let (x, y) = parseEntityFields rest in (ts:x, y) +parseExtraBlock :: Text -> NonEmpty Line -> ([[Token]], M.Map Text [ExtraLine]) +parseExtraBlock name (line :| rest) = + (x, M.insert name (NEL.toList . lineText <$> children) y) + where + (children, rest') = + span ((> lineIndent line) . lineIndent) rest + + (x, y) = + parseEntityFields rest' + isCapitalizedText :: Text -> Bool isCapitalizedText t = not (T.null t) && isUpper (T.head t) From ab76b3a4645254430f236b99bdadc3c3745ee153 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Tue, 7 Sep 2021 19:10:02 +0100 Subject: [PATCH 4/9] Update changelog --- persistent/ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 1e1bd2436..1dc494227 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -2,6 +2,8 @@ ## Unreleased +* [#1315](https://github.com/yesodweb/persistent/pull/1315) + * Refactor entity constraint parsing in Quasi module * [#1314](https://github.com/yesodweb/persistent/pull/1314) * Fix typos and minor documentation issues in Database.Persist and Database.Persist.Quasi. From 1d94446a1c28646f09632190e30b507186b5ae11 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Wed, 8 Sep 2021 07:38:50 +0100 Subject: [PATCH 5/9] Re-inline extracted function --- persistent/Database/Persist/Quasi/Internal.hs | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 63b393452..9fed806f1 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -835,21 +835,13 @@ parseEntityFields lns = case NEL.toList (tokens line) of [Token name] | isCapitalizedText name -> - parseExtraBlock name (line :| rest) + let (children, rest') = span ((> lineIndent line) . lineIndent) rest + (x, y) = parseEntityFields rest' + in (x, M.insert name (NEL.toList . lineText <$> children) y) ts -> let (x, y) = parseEntityFields rest in (ts:x, y) -parseExtraBlock :: Text -> NonEmpty Line -> ([[Token]], M.Map Text [ExtraLine]) -parseExtraBlock name (line :| rest) = - (x, M.insert name (NEL.toList . lineText <$> children) y) - where - (children, rest') = - span ((> lineIndent line) . lineIndent) rest - - (x, y) = - parseEntityFields rest' - isCapitalizedText :: Text -> Bool isCapitalizedText t = not (T.null t) && isUpper (T.head t) From 3318d915def49adde019988062e2775232eda020 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Sat, 29 Jan 2022 20:11:40 +0000 Subject: [PATCH 6/9] Implement test for behavior + modelling existing error behavior --- persistent/test/Database/Persist/QuasiSpec.hs | 84 +++++++++++++++++++ 1 file changed, 84 insertions(+) diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 8a7d45e2e..f3284131c 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -7,6 +7,7 @@ module Database.Persist.QuasiSpec where import Prelude hiding (lines) +import Control.Exception import Data.List hiding (lines) import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL @@ -339,6 +340,89 @@ Notification entityComments (unboundEntityDef car) `shouldBe` Just "This is a Car\n" entityComments (unboundEntityDef vehicle) `shouldBe` Nothing + describe "custom Id column" $ do + it "parses custom Id column" $ do + let definitions = [st| +User + Id Text + name Text + age Int +|] + let [user] = parse lowerCaseSettings definitions + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user" + let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user)) + (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"] + (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"] + (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"] + (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe` + [ FieldNameHS "name" + , FieldNameHS "age" + ] + + it "errors on duplicate custom Id column" $ do + let definitions = [st| +User + Id Text + Id Text + name Text + age Int + |] + let [user] = parse lowerCaseSettings definitions + errMsg = [st|expected only one of: UnboundIdDef {unboundIdEntityName = EntityNameHS {unEntityNameHS = "User"}, unboundIdDBName = FieldNameDB {unFieldNameDB = "id"}, unboundIdAttrs = [FieldAttrOther "Text"], unboundIdCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}, unboundIdType = Just (FTTypeCon Nothing "Text")} UnboundIdDef {unboundIdEntityName = EntityNameHS {unEntityNameHS = "User"}, unboundIdDBName = FieldNameDB {unFieldNameDB = "id"}, unboundIdAttrs = [FieldAttrOther "Text"], unboundIdCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}, unboundIdType = Just (FTTypeCon Nothing "Text")}|] + evaluate (unboundEntityDef user) `shouldThrow` + errorCall (T.unpack errMsg) + + describe "primary declaration" $ do + it "parses Primary declaration" $ do + let definitions = [st| +User + ref Text + name Text + age Int + Primary ref +|] + let [user] = parse lowerCaseSettings definitions + getUnboundEntityNameHS user `shouldBe` EntityNameHS "User" + entityDB (unboundEntityDef user) `shouldBe` EntityNameDB "user" + let idFields = NEL.toList (entitiesPrimary (unboundEntityDef user)) + (fieldHaskell <$> idFields) `shouldBe` [FieldNameHS "Id"] + (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"] + (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"] + (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe` + [ FieldNameHS "ref" + , FieldNameHS "name" + , FieldNameHS "age" + ] + + it "errors on duplicate custom Primary declaration" $ do + let definitions = [st| +User + ref Text + name Text + age Int + Primary ref + Primary name + |] + let [user] = parse lowerCaseSettings definitions + errMsg = [st|expected only one of: UnboundCompositeDef {unboundCompositeCols = [FieldNameHS {unFieldNameHS = "ref"}], unboundCompositeAttrs = []} UnboundCompositeDef {unboundCompositeCols = [FieldNameHS {unFieldNameHS = "name"}], unboundCompositeAttrs = []}|] + evaluate (unboundEntityDef user) `shouldThrow` + errorCall (T.unpack errMsg) + + it "errors on conflicting Primary/Id declarations" $ do + let definitions = [st| +User + Id Text + ref Text + name Text + age Int + Primary ref + |] + let [user] = parse lowerCaseSettings definitions + errMsg = [st|Specified both an ID field and a Primary field|] + evaluate (unboundEntityDef user) `shouldThrow` + errorCall (T.unpack errMsg) + describe "foreign keys" $ do let definitions = [st| User From bedd35383da8c55c4abf3cfcf23ea81cce0e07f2 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Sat, 29 Jan 2022 20:42:31 +0000 Subject: [PATCH 7/9] Explicit error functions --- persistent/Database/Persist/Quasi/Internal.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 9fed806f1..641c530c4 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -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 = From 1f539ddfac402057a21b4e3b297333ae731deab8 Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Sat, 29 Jan 2022 21:30:07 +0000 Subject: [PATCH 8/9] Make semigroup lawful, handle errors externally --- persistent/Database/Persist/Quasi/Internal.hs | 52 ++++++++++++------- persistent/test/Database/Persist/QuasiSpec.hs | 4 +- 2 files changed, 34 insertions(+), 22 deletions(-) diff --git a/persistent/Database/Persist/Quasi/Internal.hs b/persistent/Database/Persist/Quasi/Internal.hs index 641c530c4..847629fc8 100644 --- a/persistent/Database/Persist/Quasi/Internal.hs +++ b/persistent/Database/Persist/Quasi/Internal.hs @@ -52,7 +52,6 @@ module Database.Persist.Quasi.Internal import Prelude hiding (lines) import Control.Applicative (Alternative((<|>))) -import Control.Monad (mplus) import Data.Char (isLower, isSpace, isUpper, toLower) import Data.List (find, foldl') import Data.List.NonEmpty (NonEmpty(..)) @@ -693,10 +692,16 @@ mkUnboundEntityDef ps parsedEntDef = foldMap (maybe mempty (takeConstraint ps entNameHS cols) . NEL.nonEmpty) textAttribs idField = - entityConstraintDefsIdField entityConstraintDefs + case entityConstraintDefsIdField entityConstraintDefs of + SetMoreThanOnce -> error "expected only one Id declaration per entity" + SetOnce a -> Just a + NotSet -> Nothing primaryComposite = - entityConstraintDefsPrimaryComposite entityConstraintDefs + case entityConstraintDefsPrimaryComposite entityConstraintDefs of + SetMoreThanOnce -> error "expected only one Primary declaration per entity" + SetOnce a -> Just a + NotSet -> Nothing cols :: [UnboundFieldDef] cols = reverse . fst . foldr (associateComments ps) ([], []) $ reverse attribs @@ -917,9 +922,26 @@ getSqlNameOr def = _ -> Nothing +data SetOnceAtMost a + = NotSet + | SetOnce a + | SetMoreThanOnce + +instance Semigroup (SetOnceAtMost a) where + a <> b = + case (a, b) of + (_, NotSet) -> a + (NotSet, _) -> b + (SetOnce _, SetOnce _) -> SetMoreThanOnce + _ -> a + +instance Monoid (SetOnceAtMost a) where + mempty = + NotSet + data EntityConstraintDefs = EntityConstraintDefs - { entityConstraintDefsIdField :: Maybe UnboundIdDef - , entityConstraintDefsPrimaryComposite :: Maybe UnboundCompositeDef + { entityConstraintDefsIdField :: SetOnceAtMost UnboundIdDef + , entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef) , entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef) } @@ -927,25 +949,15 @@ data EntityConstraintDefs = EntityConstraintDefs instance Semigroup EntityConstraintDefs where a <> b = EntityConstraintDefs - { entityConstraintDefsIdField = justOneId (entityConstraintDefsIdField a) (entityConstraintDefsIdField b) - , entityConstraintDefsPrimaryComposite = justOneComposite (entityConstraintDefsPrimaryComposite a) (entityConstraintDefsPrimaryComposite b) + { entityConstraintDefsIdField = entityConstraintDefsIdField a <> entityConstraintDefsIdField b + , entityConstraintDefsPrimaryComposite = entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b , entityConstraintDefsUniques = entityConstraintDefsUniques a <> entityConstraintDefsUniques b , entityConstraintDefsForeigns = entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b } -justOneId :: Maybe UnboundIdDef -> Maybe UnboundIdDef -> Maybe UnboundIdDef -justOneId (Just x) (Just y) = error $ "expected only one of: " - `mappend` show x `mappend` " " `mappend` show 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 = - EntityConstraintDefs Nothing Nothing Nothing Nothing + EntityConstraintDefs mempty mempty Nothing Nothing entityConstraintDefsUniquesList :: EntityConstraintDefs -> [UniqueDef] entityConstraintDefsUniquesList = foldMap NEL.toList . entityConstraintDefsUniques @@ -974,12 +986,12 @@ takeConstraint ps entityName defs (n :| rest) = "Primary" -> mempty { entityConstraintDefsPrimaryComposite = - Just (takeComposite (unboundFieldNameHS <$> defs) rest) + SetOnce (takeComposite (unboundFieldNameHS <$> defs) rest) } "Id" -> mempty { entityConstraintDefsIdField = - Just (takeId ps entityName rest) + SetOnce (takeId ps entityName rest) } _ | isCapitalizedText n -> mempty diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index f3284131c..5e048d362 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -369,7 +369,7 @@ User age Int |] let [user] = parse lowerCaseSettings definitions - errMsg = [st|expected only one of: UnboundIdDef {unboundIdEntityName = EntityNameHS {unEntityNameHS = "User"}, unboundIdDBName = FieldNameDB {unFieldNameDB = "id"}, unboundIdAttrs = [FieldAttrOther "Text"], unboundIdCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}, unboundIdType = Just (FTTypeCon Nothing "Text")} UnboundIdDef {unboundIdEntityName = EntityNameHS {unEntityNameHS = "User"}, unboundIdDBName = FieldNameDB {unFieldNameDB = "id"}, unboundIdAttrs = [FieldAttrOther "Text"], unboundIdCascade = FieldCascade {fcOnUpdate = Nothing, fcOnDelete = Nothing}, unboundIdType = Just (FTTypeCon Nothing "Text")}|] + errMsg = [st|expected only one Id declaration per entity|] evaluate (unboundEntityDef user) `shouldThrow` errorCall (T.unpack errMsg) @@ -405,7 +405,7 @@ User Primary name |] let [user] = parse lowerCaseSettings definitions - errMsg = [st|expected only one of: UnboundCompositeDef {unboundCompositeCols = [FieldNameHS {unFieldNameHS = "ref"}], unboundCompositeAttrs = []} UnboundCompositeDef {unboundCompositeCols = [FieldNameHS {unFieldNameHS = "name"}], unboundCompositeAttrs = []}|] + errMsg = [st|expected only one Primary declaration per entity|] evaluate (unboundEntityDef user) `shouldThrow` errorCall (T.unpack errMsg) From 4e117223e333e46179000488e0224002b257185f Mon Sep 17 00:00:00 2001 From: Dan Brooks Date: Sat, 29 Jan 2022 21:47:31 +0000 Subject: [PATCH 9/9] Fix formatting issues --- persistent/test/Database/Persist/QuasiSpec.hs | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/persistent/test/Database/Persist/QuasiSpec.hs b/persistent/test/Database/Persist/QuasiSpec.hs index 5e048d362..ea1c7f343 100644 --- a/persistent/test/Database/Persist/QuasiSpec.hs +++ b/persistent/test/Database/Persist/QuasiSpec.hs @@ -356,9 +356,9 @@ User (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"] (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "Text"] (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe` - [ FieldNameHS "name" - , FieldNameHS "age" - ] + [ FieldNameHS "name" + , FieldNameHS "age" + ] it "errors on duplicate custom Id column" $ do let definitions = [st| @@ -367,11 +367,11 @@ User Id Text name Text age Int - |] +|] let [user] = parse lowerCaseSettings definitions errMsg = [st|expected only one Id declaration per entity|] evaluate (unboundEntityDef user) `shouldThrow` - errorCall (T.unpack errMsg) + errorCall (T.unpack errMsg) describe "primary declaration" $ do it "parses Primary declaration" $ do @@ -390,10 +390,10 @@ User (fieldDB <$> idFields) `shouldBe` [FieldNameDB "id"] (fieldType <$> idFields) `shouldBe` [FTTypeCon Nothing "UserId"] (unboundFieldNameHS <$> unboundEntityFields user) `shouldBe` - [ FieldNameHS "ref" - , FieldNameHS "name" - , FieldNameHS "age" - ] + [ FieldNameHS "ref" + , FieldNameHS "name" + , FieldNameHS "age" + ] it "errors on duplicate custom Primary declaration" $ do let definitions = [st| @@ -403,11 +403,11 @@ User age Int Primary ref Primary name - |] +|] let [user] = parse lowerCaseSettings definitions errMsg = [st|expected only one Primary declaration per entity|] evaluate (unboundEntityDef user) `shouldThrow` - errorCall (T.unpack errMsg) + errorCall (T.unpack errMsg) it "errors on conflicting Primary/Id declarations" $ do let definitions = [st| @@ -417,11 +417,11 @@ User name Text age Int Primary ref - |] +|] let [user] = parse lowerCaseSettings definitions errMsg = [st|Specified both an ID field and a Primary field|] evaluate (unboundEntityDef user) `shouldThrow` - errorCall (T.unpack errMsg) + errorCall (T.unpack errMsg) describe "foreign keys" $ do let definitions = [st|