persistent 2.13.3.1 → 2.13.3.2

raw patch · 4 files changed

+196/−57 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−1
• Database/Persist/Quasi/Internal.hs +99/−49
• persistent.cabal +1/−1
• test/Database/Persist/QuasiSpec.hs +90/−6

@@ -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),

@@ -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. --

@@ -1,5 +1,5 @@ name:            persistent-version:         2.13.3.1+version:         2.13.3.2 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>

@@ -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|