Add search parsing tests

src/Search.hs

@@ -84,13 +84,16 @@ color = do
     'r' -> Red
 
 rarity :: Parser Rarity
-rarity = do
+rarity = choice [
-  c <- oneOf "curm"
+  rarity' Common "common",
-  return $ case c of
+  rarity' Uncommon "uncommon",
-    'c' -> Common
+  rarity' Rare "rare",
-    'u' -> Uncommon
+  rarity' Mythic "mythic"
-    'r' -> Rare
+                ]
-    'm' -> Mythic
+  where
+    rarity' :: Rarity -> String -> Parser Rarity
+    rarity' constructor name =
+      choice [try (string name), try (string [head name])] >> return constructor
 
 colors :: Parser Colors
 colors =
@@ -140,11 +143,11 @@ criterion =
   choice
     [ ColorIdentityIs <$> keywords ["c", "color"] ":" colors,
       ColorIdentityLTE <$> keywords ["c", "color"] "<=" colors,
-      ColorIdentityGTE <$> keywords ["c", "color"] ">" colors,
+      ColorIdentityGTE <$> keywords ["c", "color"] ">=" colors,
       RarityIs <$> keywords ["r", "rarity"] ":" rarity,
       RarityLTE <$> keywords ["r", "rarity"] "<=" rarity,
-      RarityGTE <$> keywords ["r", "rarity"] ">" rarity,
+      RarityGTE <$> keywords ["r", "rarity"] ">=" rarity,
-      ExpansionCodeIs <$> keywords ["s", "set"] ":" literal,
+      ExpansionCodeIs <$> keywords ["s", "set", "e", "expansion"] ":" literal,
       CardTypeContains <$> keywords ["t", "type"] ":" literal,
       OracleTextContains <$> keywords ["o", "oracle"] ":" literal,
       NameContains <$> literal

test/AppSpec.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module AppSpec (spec) where
+
+import Lib (app)
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = with (return app) $ do
+  describe "GET /search" $ do
+    it "responds with 200" $ do
+      get "/search" `shouldRespondWith` 200
+    it "responds with [Card]" $ do
+      let cards =
+            [json|[
+                    {
+                      "scryfall_id": "f6cd7465-9dd0-473c-ac5e-dd9e2f22f5f6",
+                      "name": "Esika, God of the Tree // The Prismatic Bridge",
+                      "set_code": "KHM",
+                      "collector_number": "168",
+                      "rarity": "mythic",
+                      "color_identity": "WUBGR",
+                      "oracle_text": null,
+                      "prices": {
+                        "usd": "9.07",
+                        "usd_foil": "10.77",
+                        "eur": "7.79",
+                        "eur_foil": "12.27",
+                        "tix": "1.08"
+                      }
+                    },
+                    {
+                      "scryfall_id": "d761ff73-0717-4ee4-996b-f5547bcf9b2f",
+                      "name": "Go-Shintai of Life's Origin",
+                      "set_code": "NEC",
+                      "collector_number": "66",
+                      "rarity": "mythic",
+                      "color_identity": "WUBGR",
+                      "oracle_text": "{W}{U}{B}{R}{G}, {T}: Return target enchantment card from your graveyard to the battlefield.\nWhenever Go-Shintai of Life's Origin or another nontoken Shrine enters the battlefield under your control, create a 1/1 colorless Shrine enchantment creature token.",
+                      "prices": {
+                        "usd": "23.28",
+                        "usd_foil": null,
+                        "eur": "23.05",
+                        "eur_foil": null,
+                        "tix": null
+                      }
+                    },
+                    {
+                      "scryfall_id": "e2539ff7-2b7d-47e3-bd77-3138a6c42d2b",
+                      "name": "Godsire",
+                      "set_code": "ALA",
+                      "collector_number": "170",
+                      "rarity": "mythic",
+                      "color_identity": "WGR",
+                      "oracle_text": "Vigilance\n{T}: Create an 8/8 Beast creature token that's red, green, and white.",
+                      "prices": {
+                        "usd": "7.22",
+                        "usd_foil": "16.56",
+                        "eur": "4.00",
+                        "eur_foil": "13.95",
+                        "tix": "0.02"
+                      }
+                    }
+                  ]|]
+      get "/search" `shouldRespondWith` cards

test/SearchSpec.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SearchSpec (spec) where
+
+import Search (parse)
+import Data.Text
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+  describe "Search parsing" $ do
+    it "matches unquoted text as a name search" $ do
+         parseSearch "foo" `shouldBe` "Right (Search [NameContains \"foo\"])"
+    it "ignores leading and trailing whitespace" $ do
+      parseSearch "  foo  " `shouldBe` "Right (Search [NameContains \"foo\"])"
+    it "treats separate unquoted words as separate name filters" $ do
+      parseSearch "foo bar" `shouldBe` "Right (Search [NameContains \"foo\",NameContains \"bar\"])"
+    it "treats double-quoted phrases as single name filters" $ do
+      parseSearch "\"foo bar\"" `shouldBe` "Right (Search [NameContains \"foo bar\"])"
+    describe "Single colors" $ do
+      it "handles color:white" $ do
+        parseSearch "color:white" `shouldBe` "Right (Search [ColorIdentityIs {W}])"
+      it "handles color:black" $ do
+        parseSearch "color:black" `shouldBe` "Right (Search [ColorIdentityIs {B}])"
+      it "handles color:blue" $ do
+        parseSearch "color:blue" `shouldBe` "Right (Search [ColorIdentityIs {U}])"
+      it "handles color:green" $ do
+        parseSearch "color:green" `shouldBe` "Right (Search [ColorIdentityIs {G}])"
+      it "handles color:red" $ do
+        parseSearch "color:red" `shouldBe` "Right (Search [ColorIdentityIs {R}])"
+      it "handles c:white" $ do
+        parseSearch "c:white" `shouldBe` "Right (Search [ColorIdentityIs {W}])"
+      it "handles c:black" $ do
+        parseSearch "c:black" `shouldBe` "Right (Search [ColorIdentityIs {B}])"
+      it "handles c:blue" $ do
+        parseSearch "c:blue" `shouldBe` "Right (Search [ColorIdentityIs {U}])"
+      it "handles c:green" $ do
+        parseSearch "c:green" `shouldBe` "Right (Search [ColorIdentityIs {G}])"
+      it "handles c:red" $ do
+        parseSearch "c:red" `shouldBe` "Right (Search [ColorIdentityIs {R}])"
+    describe "Ravnican guilds" $ do
+      it "handles color:boros" $ do
+        parseSearch "color:boros" `shouldBe` "Right (Search [ColorIdentityIs {WR}])"
+      it "handles c:boros" $ do
+        parseSearch "c:boros" `shouldBe` "Right (Search [ColorIdentityIs {WR}])"
+      it "handles color:golgari" $ do
+        parseSearch "color:golgari" `shouldBe` "Right (Search [ColorIdentityIs {BG}])"
+      it "handles c:golgari" $ do
+        parseSearch "c:golgari" `shouldBe` "Right (Search [ColorIdentityIs {BG}])"
+      it "handles color:selesnya" $ do
+        parseSearch "color:selesnya" `shouldBe` "Right (Search [ColorIdentityIs {WG}])"
+      it "handles c:selesnya" $ do
+        parseSearch "c:selesnya" `shouldBe` "Right (Search [ColorIdentityIs {WG}])"
+      it "handles color:dimir" $ do
+        parseSearch "color:dimir" `shouldBe` "Right (Search [ColorIdentityIs {BU}])"
+      it "handles c:dimir" $ do
+        parseSearch "c:dimir" `shouldBe` "Right (Search [ColorIdentityIs {BU}])"
+      it "handles color:orzhov" $ do
+        parseSearch "color:orzhov" `shouldBe` "Right (Search [ColorIdentityIs {WB}])"
+      it "handles c:orzhov" $ do
+        parseSearch "c:orzhov" `shouldBe` "Right (Search [ColorIdentityIs {WB}])"
+      it "handles color:izzet" $ do
+        parseSearch "color:izzet" `shouldBe` "Right (Search [ColorIdentityIs {UR}])"
+      it "handles c:izzet" $ do
+        parseSearch "c:izzet" `shouldBe` "Right (Search [ColorIdentityIs {UR}])"
+      it "handles color:gruul" $ do
+        parseSearch "color:gruul" `shouldBe` "Right (Search [ColorIdentityIs {GR}])"
+      it "handles c:gruul" $ do
+        parseSearch "c:gruul" `shouldBe` "Right (Search [ColorIdentityIs {GR}])"
+      it "handles color:azorius" $ do
+        parseSearch "color:azorius" `shouldBe` "Right (Search [ColorIdentityIs {WU}])"
+      it "handles c:azorius" $ do
+        parseSearch "c:azorius" `shouldBe` "Right (Search [ColorIdentityIs {WU}])"
+      it "handles color:rakdos" $ do
+        parseSearch "color:rakdos" `shouldBe` "Right (Search [ColorIdentityIs {BR}])"
+      it "handles c:rakdos" $ do
+        parseSearch "c:rakdos" `shouldBe` "Right (Search [ColorIdentityIs {BR}])"
+      it "handles color:simic" $ do
+        parseSearch "color:simic" `shouldBe` "Right (Search [ColorIdentityIs {UG}])"
+      it "handles c:simic" $ do
+        parseSearch "c:simic" `shouldBe` "Right (Search [ColorIdentityIs {UG}])"
+    describe "Alaran shards" $ do
+      it "handles color:bant" $ do
+        parseSearch "color:bant" `shouldBe` "Right (Search [ColorIdentityIs {WUG}])"
+      it "handles c:bant" $ do
+        parseSearch "c:bant" `shouldBe` "Right (Search [ColorIdentityIs {WUG}])"
+      it "handles color:esper" $ do
+        parseSearch "color:esper" `shouldBe` "Right (Search [ColorIdentityIs {WBU}])"
+      it "handles c:esper" $ do
+        parseSearch "c:esper" `shouldBe` "Right (Search [ColorIdentityIs {WBU}])"
+      it "handles color:grixis" $ do
+        parseSearch "color:grixis" `shouldBe` "Right (Search [ColorIdentityIs {BUR}])"
+      it "handles c:grixis" $ do
+        parseSearch "c:grixis" `shouldBe` "Right (Search [ColorIdentityIs {BUR}])"
+      it "handles color:jund" $ do
+        parseSearch "color:jund" `shouldBe` "Right (Search [ColorIdentityIs {BGR}])"
+      it "handles c:jund" $ do
+        parseSearch "c:jund" `shouldBe` "Right (Search [ColorIdentityIs {BGR}])"
+      it "handles color:naya" $ do
+        parseSearch "color:naya" `shouldBe` "Right (Search [ColorIdentityIs {WGR}])"
+      it "handles c:naya" $ do
+        parseSearch "c:naya" `shouldBe` "Right (Search [ColorIdentityIs {WGR}])"
+    describe "Tarkirian wedges" $ do
+      it "handles color:abzan" $ do
+        parseSearch "color:abzan" `shouldBe` "Right (Search [ColorIdentityIs {WBG}])"
+      it "handles c:abzan" $ do
+        parseSearch "c:abzan" `shouldBe` "Right (Search [ColorIdentityIs {WBG}])"
+      it "handles color:jeskai" $ do
+        parseSearch "color:jeskai" `shouldBe` "Right (Search [ColorIdentityIs {WUR}])"
+      it "handles c:jeskai" $ do
+        parseSearch "c:jeskai" `shouldBe` "Right (Search [ColorIdentityIs {WUR}])"
+      it "handles color:sultai" $ do
+        parseSearch "color:sultai" `shouldBe` "Right (Search [ColorIdentityIs {BUG}])"
+      it "handles c:sultai" $ do
+        parseSearch "c:sultai" `shouldBe` "Right (Search [ColorIdentityIs {BUG}])"
+      it "handles color:mardu" $ do
+        parseSearch "color:mardu" `shouldBe` "Right (Search [ColorIdentityIs {WBR}])"
+      it "handles c:mardu" $ do
+        parseSearch "c:mardu" `shouldBe` "Right (Search [ColorIdentityIs {WBR}])"
+      it "handles color:temur" $ do
+        parseSearch "color:temur" `shouldBe` "Right (Search [ColorIdentityIs {UGR}])"
+      it "handles c:temur" $ do
+        parseSearch "c:temur" `shouldBe` "Right (Search [ColorIdentityIs {UGR}])"
+    describe "Multicolor" $ do
+      it "handles color:wbugr" $ do
+        parseSearch "color:wbugr" `shouldBe` "Right (Search [ColorIdentityIs {WBUGR}])"
+      it "handles c:wbugr" $ do
+        parseSearch "c:wbugr" `shouldBe` "Right (Search [ColorIdentityIs {WBUGR}])"
+      it "handles a lack of colors" $ do
+        parseSearch "c:" `shouldBe` "Right (Search [ColorIdentityIs {}])"
+    describe "Color ranges" $ do
+      it "handles color<=gr" $ do
+        parseSearch "color<=gr" `shouldBe` "Right (Search [ColorIdentityLTE {GR}])"
+      it "handles c<=gr" $ do
+        parseSearch "c<=gr" `shouldBe` "Right (Search [ColorIdentityLTE {GR}])"
+      it "handles color>=gr" $ do
+        parseSearch "color>=gr" `shouldBe` "Right (Search [ColorIdentityGTE {GR}])"
+      it "handles c>=gr" $ do
+        parseSearch "c>=gr" `shouldBe` "Right (Search [ColorIdentityGTE {GR}])"
+    describe "Rarities" $ do
+      it "handles rarity:common" $ do
+        parseSearch "rarity:common" `shouldBe` "Right (Search [RarityIs Common])"
+      it "handles rarity:c" $ do
+        parseSearch "rarity:c" `shouldBe` "Right (Search [RarityIs Common])"
+      it "handles rarity:uncommon" $ do
+        parseSearch "rarity:uncommon" `shouldBe` "Right (Search [RarityIs Uncommon])"
+      it "handles rarity:u" $ do
+        parseSearch "rarity:u" `shouldBe` "Right (Search [RarityIs Uncommon])"
+      it "handles rarity:rare" $ do
+        parseSearch "rarity:rare" `shouldBe` "Right (Search [RarityIs Rare])"
+      it "handles rarity:r" $ do
+        parseSearch "rarity:r" `shouldBe` "Right (Search [RarityIs Rare])"
+      it "handles rarity:mythic" $ do
+        parseSearch "rarity:mythic" `shouldBe` "Right (Search [RarityIs Mythic])"
+      it "handles rarity:m" $ do
+        parseSearch "rarity:m" `shouldBe` "Right (Search [RarityIs Mythic])"
+    describe "Rarity ranges" $ do
+      it "handles rarity<=rare" $ do
+        parseSearch "rarity<=rare" `shouldBe` "Right (Search [RarityLTE Rare])"
+      it "handles rarity<=r" $ do
+        parseSearch "rarity<=r" `shouldBe` "Right (Search [RarityLTE Rare])"
+      it "handles rarity>=rare" $ do
+        parseSearch "rarity>=rare" `shouldBe` "Right (Search [RarityGTE Rare])"
+      it "handles rarity>=r" $ do
+        parseSearch "rarity>=r" `shouldBe` "Right (Search [RarityGTE Rare])"
+    describe "Expansion codes with unquoted text" $ do
+      it "handles set:roe" $ do
+        parseSearch "set:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+      it "handles s:roe" $ do
+        parseSearch "s:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+      it "handles expansion:roe" $ do
+        parseSearch "expansion:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+      it "handles e:roe" $ do
+        parseSearch "e:roe" `shouldBe` "Right (Search [ExpansionCodeIs \"roe\"])"
+    describe "Card types with unquoted text" $ do
+      it "handles type:legendary" $ do
+        parseSearch "type:legendary" `shouldBe` "Right (Search [CardTypeContains \"legendary\"])"
+      it "handles t:legendary" $ do
+        parseSearch "t:legendary" `shouldBe` "Right (Search [CardTypeContains \"legendary\"])"
+    describe "Card types with double-quoted text" $ do
+      it "handles type:\"legendary creature\"" $ do
+        parseSearch "type:\"legendary creature\"" `shouldBe` "Right (Search [CardTypeContains \"legendary creature\"])"
+      it "handles t:\"legendary creature\"" $ do
+        parseSearch "t:\"legendary creature\"" `shouldBe` "Right (Search [CardTypeContains \"legendary creature\"])"
+    describe "Oracle text with unquoted text" $ do
+      it "handles oracle:destroy" $ do
+        parseSearch "oracle:destroy" `shouldBe` "Right (Search [OracleTextContains \"destroy\"])"
+      it "handles o:destroy" $ do
+        parseSearch "o:destroy" `shouldBe` "Right (Search [OracleTextContains \"destroy\"])"
+    describe "Oracle text with double-quoted text" $ do
+      it "handles oracle:\"destroy creature\"" $ do
+        parseSearch "oracle:\"destroy creature\"" `shouldBe` "Right (Search [OracleTextContains \"destroy creature\"])"
+      it "handles o:\"destroy creature\"" $ do
+        parseSearch "o:\"destroy creature\"" `shouldBe` "Right (Search [OracleTextContains \"destroy creature\"])"
+  where
+    parseSearch :: Text -> Text
+    parseSearch = pack . show . parse

test/Spec.hs

@@ -1,71 +1 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Main (main) where
-
-import Lib (app)
-import Test.Hspec
-import Test.Hspec.Wai
-import Test.Hspec.Wai.JSON
-
-main :: IO ()
-main = hspec spec
-
-spec :: Spec
-spec = with (return app) $ do
-  describe "GET /search" $ do
-    it "responds with 200" $ do
-      get "/search" `shouldRespondWith` 200
-    it "responds with [Card]" $ do
-      let cards =
-            [json|[
-                    {
-                      "scryfall_id": "f6cd7465-9dd0-473c-ac5e-dd9e2f22f5f6",
-                      "name": "Esika, God of the Tree // The Prismatic Bridge",
-                      "set_code": "KHM",
-                      "collector_number": "168",
-                      "rarity": "mythic",
-                      "color_identity": "WUBGR",
-                      "oracle_text": null,
-                      "prices": {
-                        "usd": "9.07",
-                        "usd_foil": "10.77",
-                        "eur": "7.79",
-                        "eur_foil": "12.27",
-                        "tix": "1.08"
-                      }
-                    },
-                    {
-                      "scryfall_id": "d761ff73-0717-4ee4-996b-f5547bcf9b2f",
-                      "name": "Go-Shintai of Life's Origin",
-                      "set_code": "NEC",
-                      "collector_number": "66",
-                      "rarity": "mythic",
-                      "color_identity": "WUBGR",
-                      "oracle_text": "{W}{U}{B}{R}{G}, {T}: Return target enchantment card from your graveyard to the battlefield.\nWhenever Go-Shintai of Life's Origin or another nontoken Shrine enters the battlefield under your control, create a 1/1 colorless Shrine enchantment creature token.",
-                      "prices": {
-                        "usd": "23.28",
-                        "usd_foil": null,
-                        "eur": "23.05",
-                        "eur_foil": null,
-                        "tix": null
-                      }
-                    },
-                    {
-                      "scryfall_id": "e2539ff7-2b7d-47e3-bd77-3138a6c42d2b",
-                      "name": "Godsire",
-                      "set_code": "ALA",
-                      "collector_number": "170",
-                      "rarity": "mythic",
-                      "color_identity": "WGR",
-                      "oracle_text": "Vigilance\n{T}: Create an 8/8 Beast creature token that's red, green, and white.",
-                      "prices": {
-                        "usd": "7.22",
-                        "usd_foil": "16.56",
-                        "eur": "4.00",
-                        "eur_foil": "13.95",
-                        "tix": "0.02"
-                      }
-                    }
-                  ]|]
-      get "/search" `shouldRespondWith` cards

tutor.cabal

@@ -24,6 +24,7 @@ source-repository head
 library
   exposed-modules:
       Lib
+      Search
   other-modules:
       Paths_tutor
   hs-source-dirs:
@@ -74,6 +75,8 @@ test-suite tutor-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      AppSpec
+      SearchSpec
       Paths_tutor
   hs-source-dirs:
       test