1{-# language RecordWildCards #-}
2
3import Test.Hspec
4import qualified Data.Text as T
5import Data.List.NonEmpty (NonEmpty(..))
6import qualified Data.List.NonEmpty as NEL
7import qualified Data.Map as Map
8
9import Database.Persist.Quasi
10import Database.Persist.Types
11
12main :: IO ()
13main = hspec $ do
14    describe "tokenization" $ do
15        it "handles normal words" $
16            tokenize " foo   bar  baz" `shouldBe`
17                [ Spaces 1
18                , Token "foo"
19                , Spaces 3
20                , Token "bar"
21                , Spaces 2
22                , Token "baz"
23                ]
24        it "handles quotes" $
25            tokenize "  \"foo bar\"  \"baz\"" `shouldBe`
26                [ Spaces 2
27                , Token "foo bar"
28                , Spaces 2
29                , Token "baz"
30                ]
31        it "handles quotes mid-token" $
32            tokenize "  x=\"foo bar\"  \"baz\"" `shouldBe`
33                [ Spaces 2
34                , Token "x=foo bar"
35                , Spaces 2
36                , Token "baz"
37                ]
38        it "handles escaped quote mid-token" $
39            tokenize "  x=\\\"foo bar\"  \"baz\"" `shouldBe`
40                [ Spaces 2
41                , Token "x=\\\"foo"
42                , Spaces 1
43                , Token "bar\""
44                , Spaces 2
45                , Token "baz"
46                ]
47        it "handles unnested parantheses" $
48            tokenize "  (foo bar)  (baz)" `shouldBe`
49                [ Spaces 2
50                , Token "foo bar"
51                , Spaces 2
52                , Token "baz"
53                ]
54        it "handles unnested parantheses mid-token" $
55            tokenize "  x=(foo bar)  (baz)" `shouldBe`
56                [ Spaces 2
57                , Token "x=foo bar"
58                , Spaces 2
59                , Token "baz"
60                ]
61        it "handles nested parantheses" $
62            tokenize "  (foo (bar))  (baz)" `shouldBe`
63                [ Spaces 2
64                , Token "foo (bar)"
65                , Spaces 2
66                , Token "baz"
67                ]
68        it "escaping" $
69            tokenize "  (foo \\(bar)  y=\"baz\\\"\"" `shouldBe`
70                [ Spaces 2
71                , Token "foo (bar"
72                , Spaces 2
73                , Token "y=baz\""
74                ]
75        it "mid-token quote in later token" $
76            tokenize "foo bar baz=(bin\")" `shouldBe`
77                [ Token "foo"
78                , Spaces 1
79                , Token "bar"
80                , Spaces 1
81                , Token "baz=bin\""
82                ]
83        describe "comments" $ do
84            it "recognizes one line" $ do
85                tokenize "-- | this is a comment" `shouldBe`
86                    [ DocComment "-- | this is a comment"
87                    ]
88            it "map tokenize" $ do
89                map tokenize ["Foo", "-- | Hello"]
90                    `shouldBe`
91                        [ [Token "Foo"]
92                        , [DocComment "-- | Hello"]
93                        ]
94            it "works if comment is indented" $ do
95                tokenize "  -- | comment" `shouldBe`
96                    [ Spaces 2, DocComment "-- | comment"
97                    ]
98    describe "parseFieldType" $ do
99        it "simple types" $
100            parseFieldType "FooBar" `shouldBe` Right (FTTypeCon Nothing "FooBar")
101        it "module types" $
102            parseFieldType "Data.Map.FooBar" `shouldBe` Right (FTTypeCon (Just "Data.Map") "FooBar")
103        it "application" $
104            parseFieldType "Foo Bar" `shouldBe` Right (
105                FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
106        it "application multiple" $
107            parseFieldType "Foo Bar Baz" `shouldBe` Right (
108                (FTTypeCon Nothing "Foo" `FTApp` FTTypeCon Nothing "Bar")
109                `FTApp` FTTypeCon Nothing "Baz"
110                )
111        it "parens" $ do
112            let foo = FTTypeCon Nothing "Foo"
113                bar = FTTypeCon Nothing "Bar"
114                baz = FTTypeCon Nothing "Baz"
115            parseFieldType "Foo (Bar Baz)" `shouldBe` Right (
116                foo `FTApp` (bar `FTApp` baz))
117        it "lists" $ do
118            let foo = FTTypeCon Nothing "Foo"
119                bar = FTTypeCon Nothing "Bar"
120                bars = FTList bar
121                baz = FTTypeCon Nothing "Baz"
122            parseFieldType "Foo [Bar] Baz" `shouldBe` Right (
123                foo `FTApp` bars `FTApp` baz)
124
125    describe "preparse" $ do
126        it "recognizes entity" $ do
127            preparse "Person\n  name String\n  age Int" `shouldBe`
128                [ Line { lineIndent = 0, tokens = ["Person"] }
129                , Line { lineIndent = 2, tokens = ["name", "String"] }
130                , Line { lineIndent = 2, tokens = ["age", "Int"] }
131                ]
132        describe "recognizes comments" $ do
133            let text = "Foo\n  x X\n-- | Hello\nBar\n name String"
134                linesText = T.lines text
135            it "T.lines" $ do
136                linesText
137                    `shouldBe`
138                        [ "Foo"
139                        , "  x X"
140                        , "-- | Hello"
141                        , "Bar"
142                        , " name String"
143                        ]
144            let tokens = map tokenize linesText
145            it "map tokenize" $ do
146                tokens `shouldBe`
147                    [ [ Token "Foo" ]
148                    , [ Spaces 2, Token "x", Spaces 1, Token "X"]
149                    , [ DocComment "-- | Hello" ]
150                    , [ Token "Bar" ]
151                    , [ Spaces 1, Token "name", Spaces 1, Token "String" ]
152                    ]
153            let filtered = filter (not . empty) tokens
154            it "filter (not . empty)" $ do
155                filtered `shouldBe`
156                    [ [ Token "Foo" ]
157                    , [ Spaces 2, Token "x", Spaces 1, Token "X"]
158                    , [ DocComment "-- | Hello" ]
159                    , [ Token "Bar" ]
160                    , [ Spaces 1, Token "name", Spaces 1, Token "String" ]
161                    ]
162            let spacesRemoved = removeSpaces filtered
163            it "removeSpaces" $ do
164                spacesRemoved `shouldBe`
165                    [ Line { lineIndent = 0, tokens = ["Foo"] }
166                    , Line { lineIndent = 2, tokens = ["x", "X"] }
167                    , Line { lineIndent = 0, tokens = ["-- | Hello"] }
168                    , Line { lineIndent = 0, tokens = ["Bar"] }
169                    , Line { lineIndent = 1, tokens = ["name", "String"] }
170                    ]
171
172            it "preparse" $ do
173                preparse text `shouldBe`
174                    [ Line { lineIndent = 0, tokens = ["Foo"] }
175                    , Line { lineIndent = 2, tokens = ["x", "X"] }
176                    , Line { lineIndent = 0, tokens = ["-- | Hello"] }
177                    , Line { lineIndent = 0, tokens = ["Bar"] }
178                    , Line { lineIndent = 1, tokens = ["name", "String"] }
179                    ]
180            it "preparse indented" $ do
181                let t = T.unlines
182                        [ "  Foo"
183                        , "    x X"
184                        , "  -- | Comment"
185                        , "  -- hidden comment"
186                        , "  Bar"
187                        , "    name String"
188                        ]
189                preparse t `shouldBe`
190                    [ Line { lineIndent = 2, tokens = ["Foo"] }
191                    , Line { lineIndent = 4, tokens = ["x", "X"] }
192                    , Line { lineIndent = 2, tokens = ["-- | Comment"] }
193                    , Line { lineIndent = 2, tokens = ["Bar"] }
194                    , Line { lineIndent = 4, tokens = ["name", "String"] }
195                    ]
196            it "preparse extra blocks" $ do
197                let t = T.unlines
198                        [ "LowerCaseTable"
199                        , "  name String"
200                        , "  ExtraBlock"
201                        , "    foo bar"
202                        , "    baz"
203                        , "  ExtraBlock2"
204                        , "    something"
205                        ]
206                preparse t `shouldBe`
207                    [ Line { lineIndent = 0, tokens = ["LowerCaseTable"] }
208                    , Line { lineIndent = 2, tokens = ["name", "String"] }
209                    , Line { lineIndent = 2, tokens = ["ExtraBlock"] }
210                    , Line { lineIndent = 4, tokens = ["foo", "bar"] }
211                    , Line { lineIndent = 4, tokens = ["baz"] }
212                    , Line { lineIndent = 2, tokens = ["ExtraBlock2"] }
213                    , Line { lineIndent = 4, tokens = ["something"] }
214                    ]
215            it "field comments" $ do
216                let text = T.unlines
217                        [ "-- | Model"
218                        , "Foo"
219                        , "  -- | Field"
220                        , "  name String"
221                        ]
222                preparse text `shouldBe`
223                    [ Line { lineIndent = 0, tokens = ["-- | Model"] }
224                    , Line { lineIndent = 0, tokens = ["Foo"] }
225                    , Line { lineIndent = 2, tokens = ["-- | Field"] }
226                    , Line { lineIndent = 2, tokens = ["name", "String"] }
227                    ]
228
229    describe "empty" $ do
230        it "doesn't dispatch comments" $ do
231            [DocComment "-- | hello"] `shouldSatisfy` (not . empty)
232        it "removes spaces" $ do
233            [Spaces 3] `shouldSatisfy` empty
234
235    describe "filter (not . empty)" $ do
236        let subject = filter (not . empty)
237        it "keeps comments" $ do
238            subject [[DocComment "-- | Hello"]]
239                `shouldBe`
240                    [[DocComment "-- | Hello"]]
241        it "omits lines with only spaces" $ do
242            subject [[Spaces 3, Token "indented"], [Spaces 2]]
243                `shouldBe`
244                    [[Spaces 3, Token "indented"]]
245
246    describe "removeSpaces" $ do
247        it "sets indentation level for a line" $ do
248            removeSpaces [[Spaces 3, Token "hello", Spaces 1, Token "goodbye"]]
249                `shouldBe`
250                    [ Line { lineIndent = 3, tokens = ["hello", "goodbye"] }
251                    ]
252        it "does not remove comments" $ do
253            removeSpaces
254                [ [ DocComment "-- | asdf" ]
255                , [ Token "Foo" ]
256                , [ Spaces 2, Token "name", Spaces 1, Token "String" ]
257                ]
258                `shouldBe`
259                    [ Line { lineIndent = 0, tokens = ["-- | asdf"] }
260                    , Line { lineIndent = 0, tokens = ["Foo"] }
261                    , Line { lineIndent = 2, tokens = ["name", "String"] }
262                    ]
263
264    describe "associateLines" $ do
265        let foo = Line { lineIndent = 0, tokens = pure "Foo" }
266            name'String = Line { lineIndent = 2, tokens = "name" :| ["String"] }
267            comment = Line { lineIndent = 0, tokens = pure "-- | comment" }
268        it "works" $ do
269            associateLines
270                [ comment
271                , foo
272                , name'String
273                ]
274                `shouldBe`
275                    [ LinesWithComments
276                        { lwcComments = ["comment"]
277                        , lwcLines = foo :| [name'String]
278                        }
279                    ]
280        let bar = Line { lineIndent = 0, tokens = "Bar" :| ["sql", "=", "bars"] }
281            age'Int = Line { lineIndent = 1, tokens = "age" :| ["Int"] }
282        it "works when used consecutively" $ do
283            associateLines
284                [ bar
285                , age'Int
286                , comment
287                , foo
288                , name'String
289                ]
290                `shouldBe`
291                    [ LinesWithComments
292                        { lwcComments = []
293                        , lwcLines = bar :| [age'Int]
294                        }
295                    , LinesWithComments
296                        { lwcComments = ["comment"]
297                        , lwcLines = foo :| [name'String]
298                        }
299                    ]
300        it "works with textual input" $ do
301            let text = "Foo\n  x X\n-- | Hello\nBar\n name String"
302                parsed = preparse text
303                allFull = skipEmpty parsed
304            associateLines allFull
305                `shouldBe`
306                    [ LinesWithComments
307                        { lwcLines =
308                            Line {lineIndent = 0, tokens = "Foo" :| []}
309                            :| [ Line {lineIndent = 2, tokens = "x" :| ["X"]} ]
310                        , lwcComments =
311                            []
312                        }
313                    , LinesWithComments
314                        { lwcLines =
315                            Line {lineIndent = 0, tokens = "Bar" :| []}
316                            :| [ Line {lineIndent = 1, tokens = "name" :| ["String"]}]
317                        , lwcComments =
318                            ["Hello"]
319                        }
320                    ]
321        it "works with extra blocks" $ do
322            let text = skipEmpty . preparse . T.unlines $
323                    [ "LowerCaseTable"
324                    , "    Id             sql=my_id"
325                    , "    fullName Text"
326                    , "    ExtraBlock"
327                    , "        foo bar"
328                    , "        baz"
329                    , "        bin"
330                    , "    ExtraBlock2"
331                    , "        something"
332                    ]
333            associateLines text `shouldBe`
334                [ LinesWithComments
335                    { lwcLines =
336                        Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :|
337                        [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] }
338                        , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] }
339                        , Line { lineIndent = 4, tokens = pure "ExtraBlock" }
340                        , Line { lineIndent = 8, tokens = "foo" :| ["bar"] }
341                        , Line { lineIndent = 8, tokens = pure "baz" }
342                        , Line { lineIndent = 8, tokens = pure "bin" }
343                        , Line { lineIndent = 4, tokens = pure "ExtraBlock2" }
344                        , Line { lineIndent = 8, tokens = pure "something" }
345                        ]
346                    , lwcComments = []
347                    }
348                ]
349
350        it "works with extra blocks twice" $ do
351            let text = skipEmpty . preparse . T.unlines $
352                    [ "IdTable"
353                    , "    Id Day default=CURRENT_DATE"
354                    , "    name Text"
355                    , ""
356                    , "LowerCaseTable"
357                    , "    Id             sql=my_id"
358                    , "    fullName Text"
359                    , "    ExtraBlock"
360                    , "        foo bar"
361                    , "        baz"
362                    , "        bin"
363                    , "    ExtraBlock2"
364                    , "        something"
365                    ]
366            associateLines text `shouldBe`
367                [ LinesWithComments
368                    { lwcLines = Line 0 (pure "IdTable") :|
369                        [ Line 4 ("Id" :| ["Day", "default=CURRENT_DATE"])
370                        , Line 4 ("name" :| ["Text"])
371                        ]
372                    , lwcComments = []
373                    }
374                , LinesWithComments
375                    { lwcLines =
376                        Line { lineIndent = 0, tokens = pure "LowerCaseTable" } :|
377                        [ Line { lineIndent = 4, tokens = "Id" :| ["sql=my_id"] }
378                        , Line { lineIndent = 4, tokens = "fullName" :| ["Text"] }
379                        , Line { lineIndent = 4, tokens = pure "ExtraBlock" }
380                        , Line { lineIndent = 8, tokens = "foo" :| ["bar"] }
381                        , Line { lineIndent = 8, tokens = pure "baz" }
382                        , Line { lineIndent = 8, tokens = pure "bin" }
383                        , Line { lineIndent = 4, tokens = pure "ExtraBlock2" }
384                        , Line { lineIndent = 8, tokens = pure "something" }
385                        ]
386                    , lwcComments = []
387                    }
388                ]
389
390
391        it "works with field comments" $ do
392            let text = skipEmpty . preparse . T.unlines $
393                    [ "-- | Model"
394                    , "Foo"
395                    , "  -- | Field"
396                    , "  name String"
397                    ]
398            associateLines text `shouldBe`
399                [ LinesWithComments
400                    { lwcLines =
401                        Line { lineIndent = 0, tokens = "Foo" :| [] } :|
402                            [ Line { lineIndent = 2, tokens = pure "-- | Field" }
403                            , Line { lineIndent = 2, tokens = "name" :| ["String"] }
404                            ]
405                    , lwcComments =
406                        ["Model"]
407                    }
408                ]
409
410
411
412    describe "parseLines" $ do
413        let lines =
414                T.unlines
415                    [ "-- | Comment"
416                    , "Foo"
417                    , "  -- | Field"
418                    , "  name String"
419                    , "  age  Int"
420                    , "  Extra"
421                    , "    foo bar"
422                    , "    baz"
423                    , "  Extra2"
424                    , "    something"
425                    ]
426        let [subject] = parse lowerCaseSettings lines
427        it "produces the right name" $ do
428            entityHaskell subject `shouldBe` HaskellName "Foo"
429        describe "entityFields" $ do
430            let fields = entityFields subject
431            it "has the right field names" $ do
432                map fieldHaskell fields `shouldMatchList`
433                    [ HaskellName "name"
434                    , HaskellName "age"
435                    ]
436            it "has comments" $ do
437                map fieldComments fields `shouldBe`
438                    [ Just "Field\n"
439                    , Nothing
440                    ]
441        it "has the comments" $ do
442            entityComments subject `shouldBe`
443                Just "Comment\n"
444        it "combines extrablocks" $ do
445            entityExtra subject `shouldBe` Map.fromList
446                [ ("Extra", [["foo", "bar"], ["baz"]])
447                , ("Extra2", [["something"]])
448                ]
449        describe "works with extra blocks" $ do
450            let [_, lowerCaseTable, idTable] =
451                    parse lowerCaseSettings $ T.unlines
452                    [ ""
453                    , "IdTable"
454                    , "    Id Day default=CURRENT_DATE"
455                    , "    name Text"
456                    , ""
457                    , "LowerCaseTable"
458                    , "    Id             sql=my_id"
459                    , "    fullName Text"
460                    , "    ExtraBlock"
461                    , "        foo bar"
462                    , "        baz"
463                    , "        bin"
464                    , "    ExtraBlock2"
465                    , "        something"
466                    , ""
467                    , "IdTable"
468                    , "    Id Day default=CURRENT_DATE"
469                    , "    name Text"
470                    , ""
471                    ]
472            describe "idTable" $ do
473                let EntityDef {..} = idTable
474                it "has no extra blocks" $ do
475                    entityExtra `shouldBe` mempty
476                it "has the right name" $ do
477                    entityHaskell `shouldBe` HaskellName "IdTable"
478                it "has the right fields" $ do
479                    map fieldHaskell entityFields `shouldMatchList`
480                        [ HaskellName "name"
481                        ]
482            describe "lowerCaseTable" $ do
483                let EntityDef {..} = lowerCaseTable
484                it "has the right name" $ do
485                    entityHaskell `shouldBe` HaskellName "LowerCaseTable"
486                it "has the right fields" $ do
487                    map fieldHaskell entityFields `shouldMatchList`
488                        [ HaskellName "fullName"
489                        ]
490                it "has ExtraBlock" $ do
491                    Map.lookup "ExtraBlock" entityExtra
492                        `shouldBe` Just
493                            [ ["foo", "bar"]
494                            , ["baz"]
495                            , ["bin"]
496                            ]
497                it "has ExtraBlock2" $ do
498                    Map.lookup "ExtraBlock2" entityExtra
499                        `shouldBe` Just
500                            [ ["something"]
501                            ]
502
503