Split out search parsing from search types

src/Lib.hs

@@ -44,6 +44,7 @@ import Network.Wai.Handler.Warp
 import Network.Wai.Logger
 import qualified Paths_tutor as PT
 import Search
+import SearchParser
 import Servant
   ( Description,
     Get,
@@ -316,7 +317,7 @@ searchCards :: FilePath -> Maybe T.Text -> Maybe T.Text -> Maybe T.Text -> Handl
 searchCards dbFile q sortBy inCollection =
   liftIO results
   where
-    search = Search.parse $ fromMaybe "" q
+    search = parseQuery $ fromMaybe "" q
 
     defaultOrderings :: [Query]
     defaultOrderings =

src/Search.hs

@@ -1,15 +1,10 @@
-module Search
+module Search where
-  ( 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)
+newtype Search = Search [Criteria] deriving (Show)
 
 data Criteria
   = NameContains T.Text
@@ -59,112 +54,3 @@ data Rarity
   | Rare
   | Mythic
   deriving (Eq, Ord, Show)
-
-literal :: Parser T.Text
-literal = bareLiteral <|> quotedLiteral
-  where
-    bareLiteral :: Parser T.Text
-    bareLiteral = do
-      chars <- many1 $ noneOf " \""
-      return $ T.pack chars
-
-    quotedLiteral :: Parser T.Text
-    quotedLiteral = do
-      chars <- between (char '"') (char '"') (many $ noneOf "\"")
-      return $ T.pack chars
-
-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 = choice [
-  rarity' Common "common",
-  rarity' Uncommon "uncommon",
-  rarity' Rare "rare",
-  rarity' Mythic "mythic"
-                ]
-  where
-    rarity' :: Rarity -> String -> Parser Rarity
-    rarity' constructor name =
-      choice [try (string name), try (string [head name])] >> return constructor
-
-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", "e", "expansion"] ":" 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

src/SearchParser.hs

@@ -0,0 +1,122 @@
+module SearchParser
+  ( parseQuery,
+  )
+where
+
+import qualified Control.Monad as Text.Parsec
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Search
+import Text.Parsec
+import Text.Parsec.Text (Parser)
+
+literal :: Parser T.Text
+literal = bareLiteral <|> quotedLiteral
+  where
+    bareLiteral :: Parser T.Text
+    bareLiteral = do
+      chars <- many1 $ noneOf " \""
+      return $ T.pack chars
+
+    quotedLiteral :: Parser T.Text
+    quotedLiteral = do
+      chars <- between (char '"') (char '"') (many $ noneOf "\"")
+      return $ T.pack chars
+
+color :: Parser Color
+color = do
+  c <- oneOf "wubgr"
+  case c of
+    'w' -> return White
+    'u' -> return Blue
+    'b' -> return Black
+    'g' -> return Green
+    'r' -> return Red
+    _ -> parserFail "Invalid color"
+
+rarity :: Parser Rarity
+rarity =
+  choice
+    [ rarity' Common "common",
+      rarity' Uncommon "uncommon",
+      rarity' Rare "rare",
+      rarity' Mythic "mythic"
+    ]
+  where
+    rarity' :: Rarity -> String -> Parser Rarity
+    rarity' constructor name =
+      choice [try (string name), try (string [head name])] >> return constructor
+
+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", "e", "expansion"] ":" 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
+
+parseQuery :: T.Text -> Either ParseError Search
+parseQuery = Text.Parsec.parse search "search"

test/SearchParserSpec.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module SearchSpec (spec) where
+module SearchParserSpec (spec) where
 
-import Search (parse)
 import Data.Text
+import SearchParser (parseQuery)
 import Test.Hspec
 
 main :: IO ()
@@ -13,7 +13,7 @@ spec :: Spec
 spec = do
   describe "Search parsing" $ do
     it "matches unquoted text as a name search" $ do
-         parseSearch "foo" `shouldBe` "Right (Search [NameContains \"foo\"])"
+      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
@@ -197,4 +197,4 @@ spec = do
         parseSearch "o:\"destroy creature\"" `shouldBe` "Right (Search [OracleTextContains \"destroy creature\"])"
   where
     parseSearch :: Text -> Text
-    parseSearch = pack . show . parse
+    parseSearch = pack . show . parseQuery

tutor.cabal

@@ -25,6 +25,7 @@ library
   exposed-modules:
       Lib
       Search
+      SearchParser
   other-modules:
       Paths_tutor
   hs-source-dirs:
@@ -78,7 +79,7 @@ test-suite tutor-test
   main-is: Spec.hs
   other-modules:
       AppSpec
-      SearchSpec
+      SearchParserSpec
       Paths_tutor
   hs-source-dirs:
       test