module Hunt.Query.Language.Parser
(
parseQuery
)
where
import Control.Applicative hiding (many, (<|>))
import Data.Text (Text)
import qualified Data.Text as T
import Text.Parsec
import Text.Parsec.String
import Hunt.Query.Language.Builder
import Hunt.Common.BasicTypes (mkScore)
import Hunt.Query.Language.Grammar
parseQuery :: String -> Either Text Query
parseQuery = result . parse query ""
where
result (Left err) = Left (T.pack . show $ err)
result (Right q) = Right q
query :: Parser Query
query
= do spaces
res <- orQuery'
spaces >> eof
return res
orQuery' :: Parser Query
orQuery'
= do q1 <- andQuery'
qs <- many (orOp1 >> andQuery')
return $ qOrs (q1 : qs)
where
orOp1
= try orOp'
where
orOp' = spaces >> string "OR" >> spaces1
andQuery' :: Parser Query
andQuery'
= do q1 <- neighborQuery
qs <- many $
do op <- andOp1
q <- neighborQuery
return (op, q)
return $ foldl (\ res (op', q') -> op' res q') q1 qs
where
andOp1
= try andNotOp'
<|> try andOp'
where
andNotOp'
= do spaces >> string "AND" >> spaces >> string "NOT" >> spaces1
return qAndNot
andOp' = do spaces >> string "AND" >> spaces1
return qAnd
neighborQuery :: Parser Query
neighborQuery
= do q1 <- contextSeqQuery
qs <- many $
do op <- neiOp
q <- contextSeqQuery
return (op, q)
return $ foldl (\ res (op', q') -> op' res q') q1 qs
where
neiOp
= try nextOp
<|> try nearOp
<|> try followOp
where
nextOp
= do spaces >> string "++" >> spaces1
return qNext
nearOp
= do spaces >> string "NEAR" >> spaces
d <- read <$> many1 digit
spaces1
return $ qNear d
followOp
= do spaces >> string "FOLLOW" >> spaces
d <- read <$> many1 digit
spaces1
return $ qNear d
contextSeqQuery :: Parser Query
contextSeqQuery
= do q1 <- boostQuery
qs <- many $
try (spaces1 >> boostQuery)
return $ foldl qAnd q1 qs
boostQuery :: Parser Query
boostQuery
= do q <- contextQuery
tryBoost q
contextQuery :: Parser Query
contextQuery
= do cs <- try contextSpec <|> return []
q <- primaryQuery
case cs of
[] -> return q
_ -> return (QContext cs q)
where
contextSpec
= do cs <- contexts
spaces >> char ':' >> spaces
return cs
primaryQuery :: Parser Query
primaryQuery
= parQuery
<|>
rangeQuery
<|>
caseQuery
<|>
fuzzyQuery
<|>
noCaseQuery
parQuery :: Parser Query
parQuery
= do char '(' >> spaces
q <- orQuery'
spaces >> char ')'
return q
rangeQuery :: Parser Query
rangeQuery
= do char '[' >> spaces
l <- word
spaces1 >> string "TO" >> spaces1
u <- word
spaces >> char ']' >> spaces
return $ QRange (T.pack l) (T.pack u)
caseQuery :: Parser Query
caseQuery
= do char '!' >> spaces
( phraseQuery qPhrase
<|>
wordQuery qWord
<|>
quotedWordQuery qWord )
fuzzyQuery :: Parser Query
fuzzyQuery
=do char '~' >> spaces
( wordQuery (setFuzzySearch . qWord)
<|>
quotedWordQuery (setFuzzySearch . qWord) )
noCaseQuery :: Parser Query
noCaseQuery
= phraseQuery qPhraseNoCase
<|>
quotedWordQuery qWordNoCase
<|>
wordQuery qPrefixPhraseNoCase
wordQuery :: (Text -> Query) -> Parser Query
wordQuery c = word >>= return . c . T.pack
quotedWordQuery :: (Text -> Query) -> Parser Query
quotedWordQuery c = quotedWord >>= return . c . T.pack
phraseQuery :: (Text -> Query) -> Parser Query
phraseQuery c = phrase >>= return . c . T.pack
word :: Parser String
word = try $
do w <- many1 (escapedChar <|> wordChar)
if w `elem` ["OR", "AND", "++", "NEAR", "FOLLOW"]
then parserZero
else return w
where
wordChar :: Parser Char
wordChar = noneOf notWordChar
escapedChar :: Parser Char
escapedChar = char escapeChar *> decodeChar
decodeChar :: Parser Char
decodeChar = choice (zipWith decode notWordChar notWordChar)
where decode c r = r <$ char c
escaped :: Char -> Parser Char
escaped c
= do char escapeChar
(char c <|> return escapeChar)
phrase :: Parser String
phrase
= do char '"'
p <- many1 phraseChar
char '"'
return p
where
phraseChar
= escaped '\"' <|> noneOf "\""
quotedWord :: Parser String
quotedWord
= do char '\''
p <- many1 quotedWordChar
char '\''
return p
where
quotedWordChar
= escaped '\'' <|> noneOf "'"
tryBoost :: Query -> Parser Query
tryBoost q = try boost <|> return q
where
boost = do
char '^'
b <- simplePositiveFloat
return (QBoost (mkScore b) q)
contexts :: Parser [Text]
contexts = context `sepBy1` char ','
context :: Parser Text
context = do spaces
c <- many1 alphaNum
spaces
return (T.pack c)
spaces1 :: Parser ()
spaces1 = skipMany1 space
simplePositiveNumber :: Parser String
simplePositiveNumber = many1 digit
simplePositiveFloat :: Parser Float
simplePositiveFloat = fmap read $ simplePositiveNumber <++> decimal
where decimal = option "" $ char '.' <:> simplePositiveNumber
(<++>) :: Applicative f => f [a] -> f [a] -> f [a]
(<++>) a b = (++) <$> a <*> b
(<:>) :: Applicative f => f a -> f [a] -> f [a]
(<:>) a b = (:) <$> a <*> b