diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,11 @@ # Changelog for persistent -# 2.13.3.1 +## 2.13.3.2 + +* [#1315](https://github.com/yesodweb/persistent/pull/1315) + * Refactor entity constraint parsing in Quasi module + +## 2.13.3.1 * [#1367](https://github.com/yesodweb/persistent/pull/1367), [#1366](https://github.com/yesodweb/persistent/pull/1367), diff --git a/Database/Persist/Quasi/Internal.hs b/Database/Persist/Quasi/Internal.hs --- a/Database/Persist/Quasi/Internal.hs +++ b/Database/Persist/Quasi/Internal.hs @@ -26,7 +26,7 @@ , parseFieldType , associateLines , LinesWithComments(..) - , splitExtras + , parseEntityFields , takeColsEx -- * UnboundEntityDef , UnboundEntityDef(..) @@ -52,13 +52,12 @@ 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(..)) 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 @@ -311,7 +310,7 @@ _ -> (False, EntityNameHS entityName) (attribs, extras) = - splitExtras fieldLines + parseEntityFields fieldLines isDocComment :: Token -> Maybe Text isDocComment tok = @@ -636,7 +635,7 @@ mkUnboundEntityDef ps parsedEntDef = UnboundEntityDef { unboundForeignDefs = - foreigns + entityConstraintDefsForeignsList entityConstraintDefs , unboundPrimarySpec = case (idField, primaryComposite) of (Just {}, Just {}) -> @@ -667,7 +666,7 @@ parsedEntityDefEntityAttributes parsedEntDef , entityFields = [] - , entityUniques = uniqs + , entityUniques = entityConstraintDefsUniquesList entityConstraintDefs , entityForeigns = [] , entityDerives = concat $ mapMaybe takeDerives textAttribs , entityExtra = parsedEntityDefExtras parsedEntDef @@ -689,18 +688,21 @@ 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 = + case entityConstraintDefsIdField entityConstraintDefs of + SetMoreThanOnce -> error "expected only one Id declaration per entity" + SetOnce a -> Just a + NotSet -> Nothing + + primaryComposite = + 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 @@ -801,11 +803,6 @@ [] -> 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) @@ -833,24 +830,21 @@ keyConName :: EntityNameHS -> Text keyConName entName = unEntityNameHS entName `mappend` "Id" -splitExtras +parseEntityFields :: [Line] - -> ( [[Token]] - , M.Map Text [ExtraLine] - ) -splitExtras lns = + -> ([[Token]], M.Map Text [ExtraLine]) +parseEntityFields lns = case lns of [] -> ([], M.empty) (line : rest) -> case NEL.toList (tokens line) of [Token name] | isCapitalizedText name -> - let indent = lineIndent line - (children, rest') = span ((> indent) . lineIndent) rest - (x, y) = splitExtras 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) = splitExtras rest + let (x, y) = parseEntityFields rest in (ts:x, y) isCapitalizedText :: Text -> Bool @@ -928,28 +922,84 @@ _ -> 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 :: SetOnceAtMost UnboundIdDef + , entityConstraintDefsPrimaryComposite :: SetOnceAtMost UnboundCompositeDef + , entityConstraintDefsUniques :: Maybe (NonEmpty UniqueDef) + , entityConstraintDefsForeigns :: Maybe (NonEmpty UnboundForeignDef) + } + +instance Semigroup EntityConstraintDefs where + a <> b = + EntityConstraintDefs + { entityConstraintDefsIdField = entityConstraintDefsIdField a <> entityConstraintDefsIdField b + , entityConstraintDefsPrimaryComposite = entityConstraintDefsPrimaryComposite a <> entityConstraintDefsPrimaryComposite b + , entityConstraintDefsUniques = entityConstraintDefsUniques a <> entityConstraintDefsUniques b + , entityConstraintDefsForeigns = entityConstraintDefsForeigns a <> entityConstraintDefsForeigns b + } + +instance Monoid EntityConstraintDefs where + mempty = + EntityConstraintDefs mempty mempty 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 = + SetOnce (takeComposite (unboundFieldNameHS <$> defs) rest) + } + "Id" -> + mempty + { entityConstraintDefsIdField = + SetOnce (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. -- diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.13.3.1 +version: 2.13.3.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/test/Database/Persist/QuasiSpec.hs b/test/Database/Persist/QuasiSpec.hs --- a/test/Database/Persist/QuasiSpec.hs +++ b/test/Database/Persist/QuasiSpec.hs @@ -7,6 +7,7 @@ import Prelude hiding (lines) +import Control.Exception import Data.List hiding (lines) import Data.List.NonEmpty (NonEmpty(..), (<|)) import qualified Data.List.NonEmpty as NEL @@ -23,28 +24,28 @@ 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 +60,7 @@ ) ] ) it "works5" $ do - splitExtras + parseEntityFields [ Line 0 [Token "Product"] , Line 2 (Token <$> ["name", "Text"]) , Line 4 [Token "ExtraBlock"] @@ -338,6 +339,89 @@ entityComments (unboundEntityDef bicycle) `shouldBe` Nothing 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 Id declaration per entity|] + 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 Primary declaration per entity|] + 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|