diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,14 +1,18 @@ # Changelog for persistent +## 2.11.0.2 + +* Fix a bug where an empty entity definition would break parsing of `EntityDef`s. [#1176](https://github.com/yesodweb/persistent/issues/1176) + ## 2.11.0.1 -* Docs/Bugs fixes [#1153] https://github.com/yesodweb/persistent/pull/1153 +* Docs/Bugs fixes [#1153](https://github.com/yesodweb/persistent/pull/1153) * Fix documentation on `FieldDef.fieldAttrs`. * Postgresql backend: Add a space in cascade clause of generated SQL. ## 2.11.0.0 -* Foreign Key improvements [#1121] https://github.com/yesodweb/persistent/pull/1121 +* Foreign Key improvements [#1121](https://github.com/yesodweb/persistent/pull/1121) * It is now supported to refer to a table with an auto generated Primary Kay * It is now supported to refer to non-primary fields, using the keyword `References` * It is now supported to have cascade options for simple/single-field Foreign Keys diff --git a/Database/Persist/Quasi.hs b/Database/Persist/Quasi.hs --- a/Database/Persist/Quasi.hs +++ b/Database/Persist/Quasi.hs @@ -699,6 +699,7 @@ consComment comment lwc : lwcs _ -> if lineIndent line <= lineIndent (firstLine lwc) + && lineIndent (firstLine lwc) /= lowestIndent then consLine line lwc : lwcs else diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.11.0.1 +version: 2.11.0.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -98,6 +98,7 @@ , http-api-data , path-pieces , scientific + , shakespeare , text , time , transformers diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,11 +1,14 @@ -{-# language RecordWildCards, OverloadedStrings #-} +{-# language RecordWildCards, OverloadedStrings, QuasiQuotes #-} import Test.Hspec +import qualified Data.Char as Char import qualified Data.Text as T import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Time +import Text.Shakespeare.Text +import Data.List import Database.Persist.Class.PersistField import Database.Persist.Quasi @@ -220,6 +223,138 @@ parseFieldType "Foo [Bar] Baz" `shouldBe` Right ( foo `FTApp` bars `FTApp` baz) + describe "#1175 empty entity" $ do + let subject = + [st| +Foo + name String + age Int + +EmptyEntity + +Bar + name String + +Baz + a Int + b String + c FooId + |] + + let preparsed = + preparse subject + it "preparse works" $ do + length preparsed + `shouldBe` do + length . filter (not . T.all Char.isSpace) . T.lines + $ subject + + let skippedEmpty = + skipEmpty preparsed + fooLines = + [ Line + { lineIndent = 0 + , tokens = "Foo" :| [] + } + , Line + { lineIndent = 4 + , tokens = "name" :| ["String"] + } + , Line + { lineIndent = 4 + , tokens = "age" :| ["Int"] + } + ] + emptyLines = + [ Line + { lineIndent = 0 + , tokens = "EmptyEntity" :| [] + } + ] + barLines = + [ Line + { lineIndent = 0 + , tokens = "Bar" :| [] + } + , Line + { lineIndent = 4 + , tokens = "name" :| ["String"] + } + ] + bazLines = + [ Line + { lineIndent = 0 + , tokens = "Baz" :| [] + } + , Line + { lineIndent = 4 + , tokens = "a" :| ["Int"] + } + , Line + { lineIndent = 4 + , tokens = "b" :| ["String"] + } + , Line + { lineIndent = 4 + , tokens = "c" :| ["FooId"] + } + ] + resultLines = + concat + [ fooLines + , emptyLines + , barLines + , bazLines + ] + + it "skipEmpty works" $ do + skippedEmpty `shouldBe` resultLines + + let linesAssociated = + associateLines skippedEmpty + it "associateLines works" $ do + linesAssociated `shouldMatchList` + [ LinesWithComments + { lwcLines = NEL.fromList fooLines + , lwcComments = [] + } + , LinesWithComments (NEL.fromList emptyLines) [] + , LinesWithComments (NEL.fromList barLines) [] + , LinesWithComments (NEL.fromList bazLines) [] + ] + + let parsed = + parse lowerCaseSettings subject + it "parse works" $ do + let test name'fieldCount xs = do + case (name'fieldCount, xs) of + ([], []) -> + pure () + (((name, fieldCount) :_), []) -> + expectationFailure + $ "Expected an entity with name " + <> name + <> " and " <> show fieldCount <> " fields" + <> ", but the list was empty..." + ((name, fieldCount) : ys, (EntityDef {..} : xs)) -> do + (unHaskellName entityHaskell, length entityFields) + `shouldBe` + (T.pack name, fieldCount) + test ys xs + + result = + parse lowerCaseSettings subject + length parsed `shouldBe` 4 + + test + [ ("Foo", 2) + , ("EmptyEntity", 0) + , ("Bar", 1) + , ("Baz", 3) + ] + parsed + + describe "preparse" $ do it "recognizes entity" $ do preparse "Person\n name String\n age Int" `shouldBe` @@ -546,27 +681,34 @@ ] describe "works with extra blocks" $ do let [_, lowerCaseTable, idTable] = - parse lowerCaseSettings $ T.unlines - [ "" - , "IdTable" - , " Id Day default=CURRENT_DATE" - , " name Text" - , "" - , "LowerCaseTable" - , " Id sql=my_id" - , " fullName Text" - , " ExtraBlock" - , " foo bar" - , " baz" - , " bin" - , " ExtraBlock2" - , " something" - , "" - , "IdTable" - , " Id Day default=CURRENT_DATE" - , " name Text" - , "" - ] + case parse lowerCaseSettings $ T.unlines + [ "" + , "IdTable" + , " Id Day default=CURRENT_DATE" + , " name Text" + , "" + , "LowerCaseTable" + , " Id sql=my_id" + , " fullName Text" + , " ExtraBlock" + , " foo bar" + , " baz" + , " bin" + , " ExtraBlock2" + , " something" + , "" + , "IdTable" + , " Id Day default=CURRENT_DATE" + , " name Text" + , "" + ] of + [a, b, c] -> + [a, b, c] + xs -> + error + $ "Expected 3 elements in list, got: " + <> show (length xs) + <> ", list contents: \n\n" <> intercalate "\n" (map show xs) describe "idTable" $ do let EntityDef {..} = idTable it "has no extra blocks" $ do