Grammar.hs

-- ----------------------------------------------------------------------------

{- |
  Module     : Holumbus.Query.Language.Grammar
  Copyright  : Copyright (C) 2007, 2008 Timo B. Huebel
  License    : MIT

  Maintainer : Timo B. Huebel (tbh@holumbus.org)
  Stability  : experimental
  Portability: portable
  Version    : 0.2

  The Holumbus query language definition. 
  
  The specific syntax of any query language can be designed independently 
  by creating appropriate parsers. Also see "Holumbus.Query.Language.Parser".

-}

-- ----------------------------------------------------------------------------

module Holumbus.Query.Language.Grammar
  (
  -- * Query data types
  Query (Word, Phrase, CaseWord, CasePhrase, FuzzyWord, Specifier, Negation, BinQuery)
  , BinOp (And, Or, But)

  -- * Optimizing
  , optimize
  , checkWith
  , extractTerms
  )
where

import Data.Char
import Data.List
import Data.Binary
import Control.Monad

import Holumbus.Index.Common (Context)

-- | The query language.
data Query = Word       String            -- ^ Single case-insensitive word.
           | Phrase     String            -- ^ Single case-insensitive phrase.
           | CaseWord   String            -- ^ Single case-sensitive word.
           | CasePhrase String            -- ^ Single case-sensitive phrase.
           | FuzzyWord  String            -- ^ Single fuzzy word.
           | Specifier  [Context] Query   -- ^ Restrict query to a list of contexts.
           | Negation   Query             -- ^ Negate the query.
           | BinQuery   BinOp Query Query -- ^ Combine two queries through a binary operation.
           deriving (Eq, Show)

-- | A binary operation.
data BinOp = And  -- ^ Intersect two queries.
           | Or   -- ^ Union two queries.
           | But  -- ^ Filter a query by another, @q1 BUT q2@ is equivalent to @q1 AND NOT q2@.
           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"

-- | Transforms all @(BinQuery And q1 q2)@ where one of @q1@ or @q2@ is a @Negation@ into
-- @BinQuery Filter q1 q2@ or @BinQuery Filter q2 q1@ respectively.
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

-- | Check if the query arguments comply with some custom predicate.
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

-- | Returns a list of all terms in the query.
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 _ = []