[yesodweb#1175] Empty Entity Parsing (yesodweb#1176)

* [yesodweb#1175] Empty Entity Parsing * ok, problem is in associateLines * Tests pass * cabal, changelog * oops * oops
mytskine · Dec 11, 2020 · 8e92f11 · 8e92f11
1 parent e98f4b1
commit 8e92f11
Show file tree

Hide file tree

Showing 4 changed files with 171 additions and 23 deletions.
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
@@ -1,5 +1,9 @@
 # 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)

diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs
@@ -699,6 +699,7 @@ associateLines lines =
                         consComment comment lwc : lwcs
                     _ ->
                         if lineIndent line <= lineIndent (firstLine lwc)
+                            && lineIndent (firstLine lwc) /= lowestIndent
                         then
                             consLine line lwc : lwcs
                         else

diff --git a/persistent/persistent.cabal b/persistent/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 <[email protected]>
@@ -98,6 +98,7 @@ test-suite test
                    , http-api-data
                    , path-pieces
                    , scientific
+                   , shakespeare
                    , text
                    , time
                    , transformers

diff --git a/persistent/test/main.hs b/persistent/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 @@ main = hspec $ do
             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 @@ main = hspec $ do
                 ]
         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