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