Add search parsing

Search.hs

@@ -1,12 +1,13 @@
 module Search
-  ( colors,
-    colorless,
-    parse
+  ( Search.parse,
   )
 where
 
+import qualified Data.Char as C
 import qualified Data.Set as Set
 import qualified Data.Text as T
+import Text.Parsec
+import Text.Parsec.Text (Parser)
 
 data Search = Search [Criteria] deriving (Show)
 
@@ -59,13 +60,108 @@ data Rarity
   | Mythic
   deriving (Eq, Ord, Show)
 
-colors :: [Color] -> Colors
-colors = Colors . Set.fromList
+literal :: Parser T.Text
+literal = bareLiteral <|> quotedLiteral
+  where
+    bareLiteral :: Parser T.Text
+    bareLiteral = do
+      chars <- many1 $ noneOf " \""
+      return $ T.pack chars
 
-colorless :: Colors -> Bool
-colorless (Colors xs)
-  | Set.null xs = True
-  | otherwise = False
+    quotedLiteral :: Parser T.Text
+    quotedLiteral = do
+      chars <- between (char '"') (char '"') (many $ noneOf "\"")
+      return $ T.pack chars
 
-parse :: T.Text -> Search
-parse _ = Search []
+color :: Parser Color
+color = do
+  c <- oneOf "wubgr"
+  return $ case c of
+    'w' -> White
+    'u' -> Blue
+    'b' -> Black
+    'g' -> Green
+    'r' -> Red
+
+rarity :: Parser Rarity
+rarity = do
+  c <- oneOf "curm"
+  return $ case c of
+    'c' -> Common
+    'u' -> Uncommon
+    'r' -> Rare
+    'm' -> Mythic
+
+colors :: Parser Colors
+colors =
+  choice
+    [ -- Single colors
+      colorGroup "white" [White],
+      colorGroup "black" [Black],
+      colorGroup "blue" [Blue],
+      colorGroup "green" [Green],
+      colorGroup "red" [Red],
+      -- Ravnican Guilds
+      colorGroup "boros" [Red, White],
+      colorGroup "golgari" [Green, Black],
+      colorGroup "selesnya" [Green, White],
+      colorGroup "dimir" [Blue, Black],
+      colorGroup "orzhov" [White, Black],
+      colorGroup "izzet" [Red, Blue],
+      colorGroup "gruul" [Red, Green],
+      colorGroup "azorius" [Blue, White],
+      colorGroup "rakdos" [Black, Red],
+      colorGroup "simic" [Green, Blue],
+      -- Alaran Shards
+      colorGroup "bant" [White, Green, Blue],
+      colorGroup "esper" [Blue, White, Black],
+      colorGroup "grixis" [Black, Blue, Red],
+      colorGroup "jund" [Red, Black, Green],
+      colorGroup "naya" [Green, Red, White],
+      -- Tarkirian Wedges
+      colorGroup "abzan" [White, Black, Green],
+      colorGroup "jeskai" [White, Blue, Red],
+      colorGroup "sultai" [Blue, Black, Green],
+      colorGroup "mardu" [White, Black, Red],
+      colorGroup "temur" [Blue, Red, Green],
+      -- Multicolor
+      multiColor
+    ]
+  where
+    colorGroup :: String -> [Color] -> Parser Colors
+    colorGroup name xs = try (string name) >> return (Colors $ Set.fromList xs)
+    multiColor :: Parser Colors
+    multiColor = do
+      xs <- many color
+      return $ Colors $ Set.fromList xs
+
+criterion :: Parser Criteria
+criterion =
+  choice
+    [ ColorIdentityIs <$> keywords ["c", "color"] ":" colors,
+      ColorIdentityLTE <$> keywords ["c", "color"] "<=" colors,
+      ColorIdentityGTE <$> keywords ["c", "color"] ">" colors,
+      RarityIs <$> keywords ["r", "rarity"] ":" rarity,
+      RarityLTE <$> keywords ["r", "rarity"] "<=" rarity,
+      RarityGTE <$> keywords ["r", "rarity"] ">" rarity,
+      ExpansionCodeIs <$> keywords ["s", "set"] ":" literal,
+      CardTypeContains <$> keywords ["t", "type"] ":" literal,
+      OracleTextContains <$> keywords ["o", "oracle"] ":" literal,
+      NameContains <$> literal
+    ]
+  where
+    -- Attempt a keyword and operator pair without consuming input.
+    keyword :: String -> String -> Parser String
+    keyword operator name = try $ string (name <> operator)
+
+    -- Attempt to match a set of keywords with an operator, using parser on success.
+    keywords :: [String] -> String -> Parser a -> Parser a
+    keywords names operator parser = (choice $ map (keyword operator) names) >> parser
+
+search :: Parser Search
+search = do
+  criteria <- spaces >> sepEndBy criterion spaces
+  return $ Search criteria
+
+parse :: T.Text -> Either ParseError Search
+parse query = Text.Parsec.parse search "search" query

package.yaml

@@ -24,6 +24,8 @@ dependencies:
 - containers
 - lens
 - openapi3
+- parsec
+- parsec-extra
 - servant-openapi3
 - servant-server
 - text

stack.yaml

@@ -42,6 +42,7 @@ packages:
 extra-deps:
   - hspec-wai-0.11.0@sha256:79f8aab21161cd551e0bb740f5416fb622fe94f710bedc97dabd39fe901b5291,2314
   - hspec-wai-json-0.11.0@sha256:1fdd66a61c84a9ba6f2e1673ed49b2da1f57f025cd3fb9a46d62620ff9259d63,1629
+  - parsec-extra-0.2.0.0@sha256:47f16e5d00cb62db52d126903787dcccc94d500cfbcb54316f5db00f31da4fa2,735
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack.yaml.lock

@@ -18,6 +18,13 @@ packages:
       sha256: c25b93d8e0140a9ea24605199de5065967cd5fceeacac2b7f7d0747ab2142778
   original:
     hackage: hspec-wai-json-0.11.0@sha256:1fdd66a61c84a9ba6f2e1673ed49b2da1f57f025cd3fb9a46d62620ff9259d63,1629
+- completed:
+    hackage: parsec-extra-0.2.0.0@sha256:47f16e5d00cb62db52d126903787dcccc94d500cfbcb54316f5db00f31da4fa2,735
+    pantry-tree:
+      size: 225
+      sha256: 8d8d15ac5aca977855d1fe89f3f23ecbbddc604e3cb887af5c27b540dba49ffc
+  original:
+    hackage: parsec-extra-0.2.0.0@sha256:47f16e5d00cb62db52d126903787dcccc94d500cfbcb54316f5db00f31da4fa2,735
 snapshots:
 - completed:
     size: 616897

tutor.cabal

@@ -34,6 +34,8 @@ library
     , containers
     , lens
     , openapi3
+    , parsec
+    , parsec-extra
     , servant-openapi3
     , servant-server
     , text
@@ -56,6 +58,8 @@ executable tutor-exe
     , containers
     , lens
     , openapi3
+    , parsec
+    , parsec-extra
     , servant-openapi3
     , servant-server
     , text
@@ -83,6 +87,8 @@ test-suite tutor-test
     , hspec-wai-json
     , lens
     , openapi3
+    , parsec
+    , parsec-extra
     , servant-openapi3
     , servant-server
     , text