module Holumbus.Query.Language.Grammar
(
Query (Word, Phrase, CaseWord, CasePhrase, FuzzyWord, Specifier, Negation, BinQuery)
, BinOp (And, Or, But)
, optimize
, checkWith
, extractTerms
)
where
import Data.Char
import Data.List
import Data.Binary
import Control.Monad
import Holumbus.Index.Common (Context)
data Query = Word String
| Phrase String
| CaseWord String
| CasePhrase String
| FuzzyWord String
| Specifier [Context] Query
| Negation Query
| BinQuery BinOp Query Query
deriving (Eq, Show)
data BinOp = And
| Or
| But
deriving (Eq, Show)
instance Binary Query where
put (Word s) = put (0 :: Word8) >> put s
put (Phrase s) = put (1 :: Word8) >> put s
put (CaseWord s) = put (2 :: Word8) >> put s
put (CasePhrase s) = put (3 :: Word8) >> put s
put (FuzzyWord s) = put (4 :: Word8) >> put s
put (Specifier c q) = put (5 :: Word8) >> put c >> put q
put (Negation q) = put (6 :: Word8) >> put q
put (BinQuery o q1 q2) = put (7 :: Word8) >> put o >> put q1 >> put q2
get = do tag <- getWord8
case tag of
0 -> liftM Word get
1 -> liftM Phrase get
2 -> liftM CaseWord get
3 -> liftM CasePhrase get
4 -> liftM FuzzyWord get
5 -> liftM2 Specifier get get
6 -> liftM Negation get
7 -> liftM3 BinQuery get get get
_ -> fail "Error while decoding Query"
instance Binary BinOp where
put And = put (0 :: Word8)
put Or = put (1 :: Word8)
put But = put (2 :: Word8)
get = do tag <- getWord8
case tag of
0 -> return And
1 -> return Or
2 -> return But
_ -> fail "Error while decoding BinOp"
optimize :: Query -> Query
optimize q@(BinQuery And (Word q1) (Word q2)) =
if (map toLower q1) `isPrefixOf` (map toLower q2) then Word q2 else
if (map toLower q2) `isPrefixOf` (map toLower q1) then Word q1 else q
optimize q@(BinQuery And (CaseWord q1) (CaseWord q2)) =
if q1 `isPrefixOf` q2 then CaseWord q2 else
if q2 `isPrefixOf` q1 then CaseWord q1 else q
optimize q@(BinQuery Or (Word q1) (Word q2)) =
if (map toLower q1) `isPrefixOf` (map toLower q2) then Word q1 else
if (map toLower q2) `isPrefixOf` (map toLower q1) then Word q2 else q
optimize q@(BinQuery Or (CaseWord q1) (CaseWord q2)) =
if q1 `isPrefixOf` q2 then CaseWord q1 else
if q2 `isPrefixOf` q1 then CaseWord q2 else q
optimize (BinQuery And q1 (Negation q2)) = BinQuery But (optimize q1) (optimize q2)
optimize (BinQuery And (Negation q1) q2) = BinQuery But (optimize q2) (optimize q1)
optimize (BinQuery And q1 q2) = BinQuery And (optimize q1) (optimize q2)
optimize (BinQuery Or q1 q2) = BinQuery Or (optimize q1) (optimize q2)
optimize (BinQuery But q1 q2) = BinQuery But (optimize q1) (optimize q2)
optimize (Negation q) = Negation (optimize q)
optimize (Specifier cs q) = Specifier cs (optimize q)
optimize q = q
checkWith :: (String -> Bool) -> Query -> Bool
checkWith f (Word s) = f s
checkWith f (Phrase s) = f s
checkWith f (CaseWord s) = f s
checkWith f (CasePhrase s) = f s
checkWith f (FuzzyWord s) = f s
checkWith f (Negation q) = checkWith f q
checkWith f (BinQuery _ q1 q2) = (checkWith f q1) && (checkWith f q2)
checkWith f (Specifier _ q) = checkWith f q
extractTerms :: Query -> [String]
extractTerms (Word s) = [s]
extractTerms (CaseWord s) = [s]
extractTerms (FuzzyWord s) = [s]
extractTerms (Specifier _ q) = extractTerms q
extractTerms (Negation q) = extractTerms q
extractTerms (BinQuery _ q1 q2) = (extractTerms q1) ++ (extractTerms q2)
extractTerms _ = []