From 4df535f3c528a3e57d532fee969cf0e0b67abf9a Mon Sep 17 00:00:00 2001 From: Correl Date: Sun, 27 Mar 2022 14:02:11 -0400 Subject: [PATCH] Split out search parsing from search types --- src/Lib.hs | 3 +- src/Search.hs | 118 +------------------ src/SearchParser.hs | 122 ++++++++++++++++++++ test/{SearchSpec.hs => SearchParserSpec.hs} | 8 +- tutor.cabal | 3 +- 5 files changed, 132 insertions(+), 122 deletions(-) create mode 100644 src/SearchParser.hs rename test/{SearchSpec.hs => SearchParserSpec.hs} (98%) diff --git a/src/Lib.hs b/src/Lib.hs index a827f24..cdcbbb7 100644 --- a/src/Lib.hs +++ b/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 = diff --git a/src/Search.hs b/src/Search.hs index e410b7a..bddf955 100644 --- a/src/Search.hs +++ b/src/Search.hs @@ -1,15 +1,10 @@ -module Search - ( Search.parse, - ) -where +module Search 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 diff --git a/src/SearchParser.hs b/src/SearchParser.hs new file mode 100644 index 0000000..145aecb --- /dev/null +++ b/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" diff --git a/test/SearchSpec.hs b/test/SearchParserSpec.hs similarity index 98% rename from test/SearchSpec.hs rename to test/SearchParserSpec.hs index f360da0..7d8b72c 100644 --- a/test/SearchSpec.hs +++ b/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 diff --git a/tutor.cabal b/tutor.cabal index b4b5d82..3830e77 100644 --- a/tutor.cabal +++ b/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