content: {-# OPTIONS #-}
  
  -- ----------------------------------------------------------------------------
  
  {- |
    Module     : Holumbus.Query.Processor
    Copyright  : Copyright (C) 2007, 2008 Timo B. Huebel
    License    : MIT
  
    Maintainer : Timo B. Huebel (tbh@holumbus.org)
    Stability  : experimental
    Portability: portable
  
    The Holumbus query processor. Supports exact word or phrase queries as well
    as fuzzy word and case-insensitive word and phrase queries. Boolean
    operators like AND, OR and NOT are supported. Context specifiers and
    priorities are supported, too.
  
  -}
  
  -- ----------------------------------------------------------------------------
  
  module Holumbus.Query.Processor 
    (
    -- * Processor types
    ProcessConfig (..)
    
    -- * Processing
    , processQuery
    , processPartial
    , processQueryM
    , processPartialM
    )
  where
  
  -- import Data.Maybe
  
  import           Control.Monad
  import           Control.Parallel.Strategies
  
  import           Data.Binary                    ( Binary (..) )
  import           Data.Function
  import qualified Data.List                      as L
  
  import           Holumbus.Index.Common          hiding (contexts)
  import qualified Holumbus.Index.Common          as IDX
  
  import           Holumbus.Query.Language.Grammar
  
  import           Holumbus.Query.Fuzzy           ( FuzzyScore
                                                  , FuzzyConfig
                                                  )
  import qualified Holumbus.Query.Fuzzy           as F
  
  import           Holumbus.Query.Result          ( Result )
  
  import           Holumbus.Query.Intermediate    ( Intermediate )
  import qualified Holumbus.Query.Intermediate    as I
  
  -- ----------------------------------------------------------------------------
  
  -- | The configuration for the query processor.
  
  data ProcessConfig
      = ProcessConfig 
        { fuzzyConfig   :: ! FuzzyConfig -- ^ The configuration for fuzzy queries.
        , optimizeQuery :: ! Bool        -- ^ Optimize the query before processing.
        , wordLimit     :: ! Int         -- ^ The maximum number of words used from a prefix. Zero switches off limiting.
        , docLimit      :: ! Int         -- ^ The maximum number of documents taken into account. Zero switches off limiting.
        }
  
  instance Binary ProcessConfig where
    put (ProcessConfig fc o l d)
        = put fc >> put o >> put l >> put d
    get
        = liftM4 ProcessConfig get get get get
  
  -- | The internal state of the query processor.
  data ProcessState i
      = ProcessState 
        { config   :: ! ProcessConfig   -- ^ The configuration for the query processor.
        , contexts :: ! [Context]       -- ^ The current list of contexts.
        , index    :: ! i               -- ^ The index to search.
        , total    :: ! Int             -- ^ The number of documents in the index.
        }
  
  -- ----------------------------------------------------------------------------
  
  -- | Get the fuzzy config out of the process state.
  
  getFuzzyConfig :: HolIndex i => ProcessState i -> FuzzyConfig
  getFuzzyConfig = fuzzyConfig . config
  
  -- | Monadic version of 'getFuzzyConfig'.
  
  getFuzzyConfigM :: HolIndexM m i => ProcessState i -> m FuzzyConfig
  getFuzzyConfigM s = return $ fuzzyConfig $ config s
  
  -- | Set the current context in the state.
  
  setContexts :: HolIndex i => [Context] -> ProcessState i -> ProcessState i
  setContexts cs (ProcessState cfg _ i t) = ProcessState cfg cs i t
  
  -- | Monadic version of 'setContexts'.
  
  setContextsM :: HolIndexM m i => [Context] -> ProcessState i -> m (ProcessState i)
  setContextsM cs (ProcessState cfg _ i t) = return $ ProcessState cfg cs i t
  
  -- | Initialize the state of the processor.
  
  initState :: HolIndex i => ProcessConfig -> i -> Int -> ProcessState i
  initState cfg i t = ProcessState cfg (IDX.contexts i) i t
  
  -- | Monadic version of 'initState'.
  
  initStateM :: HolIndexM m i => ProcessConfig -> i -> Int -> m (ProcessState i)
  initStateM cfg i t = IDX.contextsM i >>= \cs -> return $ ProcessState cfg cs i t
  
  -- | Try to evaluate the query for all contexts in parallel.
  
  forAllContexts :: (Context -> Intermediate) -> [Context] -> Intermediate
  forAllContexts f cs = L.foldl' I.union I.emptyIntermediate $ parMap rdeepseq f cs
  
  -- | Monadic version of 'forAllContexts'.
  
  forAllContextsM :: Monad m => (Context -> m Intermediate) -> [Context] -> m Intermediate
  forAllContextsM f cs = mapM f cs >>= \is -> return $ L.foldl' I.union I.emptyIntermediate is
  
  -- | Just everything.
  
  allDocuments :: HolIndex i => ProcessState i -> Intermediate
  allDocuments s = forAllContexts (\c -> I.fromList "" c $ IDX.allWords (index s) c) (contexts s)
  
  allDocumentsM :: HolIndexM m i => ProcessState i -> m Intermediate
  allDocumentsM s = forAllContextsM (\c -> IDX.allWordsM (index s) c >>= \r -> return $ I.fromList "" c r) (contexts s)
  
  -- | Process a query only partially in terms of a distributed index. Only the intermediate 
  -- result will be returned.
  
  processPartial :: (HolIndex i) => ProcessConfig -> i -> Int -> Query -> Intermediate
  processPartial cfg i t q = process (initState cfg i t) oq
    where
    oq = if optimizeQuery cfg then optimize q else q
  
  -- | Monadic version of 'processPartial'.
  
  processPartialM :: (HolIndexM m i) => ProcessConfig -> i -> Int -> Query -> m Intermediate
  processPartialM cfg i t q = initStateM cfg i t >>= (flip processM) oq
    where
    oq = if optimizeQuery cfg then optimize q else q
  
  -- | Process a query on a specific index with regard to the configuration.
  
  processQuery :: (HolIndex i, HolDocuments d c) => ProcessConfig -> i -> d c -> Query -> Result c
  processQuery cfg i d q = I.toResult d (processPartial cfg i (sizeDocs d) q)
  
  -- | Monadic version of 'processQuery'.
  
  processQueryM :: (HolIndexM m i, HolDocuments d c) => ProcessConfig -> i -> d c -> Query -> m (Result c)
  processQueryM cfg i d q = processPartialM cfg i (sizeDocs d) q >>= \ir -> return $ I.toResult d ir
  
  -- | Continue processing a query by deciding what to do depending on the current query element.
  
  process :: HolIndex i => ProcessState i -> Query -> Intermediate
  process s (Word w)           = processWord s w
  process s (Phrase w)         = processPhrase s w
  process s (CaseWord w)       = processCaseWord s w
  process s (CasePhrase w)     = processCasePhrase s w
  process s (FuzzyWord w)      = processFuzzyWord s w
  process s (Negation q)       = processNegation s (process s q)
  process s (Specifier c q)    = process (setContexts c s) q
  process s (BinQuery o q1 q2) = processBin o (process s q1) (process s q2)
  
  -- | Monadic version of 'process'.
  
  processM :: HolIndexM m i => ProcessState i -> Query -> m Intermediate
  processM s (Word w)           = processWordM s w
  processM _ (Phrase _)         = return I.emptyIntermediate -- processPhraseM s w
  processM s (CaseWord w)       = processCaseWordM s w
  processM _ (CasePhrase _)     = return I.emptyIntermediate -- processCasePhraseM s w
  processM s (FuzzyWord w)      = processFuzzyWordM s w
  processM s (Negation q)       = processM s q >>= processNegationM s
  processM s (Specifier c q)    = setContextsM c s >>= \ns -> processM ns q
  processM s (BinQuery o q1 q2) = do
    ir1 <- processM s q1
    ir2 <- processM s q2
    return $ processBin o ir1 ir2
  
  -- | Process a single, case-insensitive word by finding all documents whreturn I.emptyIntermediate -- ich contain the word as prefix.
  
  processWord :: HolIndex i => ProcessState i -> String -> Intermediate
  processWord s q = forAllContexts wordNoCase (contexts s)
    where
    wordNoCase c = I.fromList q c $ limitWords s $ IDX.prefixNoCase (index s) c q
  
  -- | Monadic version of 'processWord'.
  
  processWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate
  processWordM s q = forAllContextsM wordNoCase (contexts s)
    where
    wordNoCase c = IDX.prefixNoCaseM (index s) c q >>= limitWordsM s >>= \r -> return $ I.fromList q c r
  
  -- | Process a single, case-sensitive word by finding all documents which contain the word as prefix.
  
  processCaseWord :: HolIndex i => ProcessState i -> String -> Intermediate
  processCaseWord s q = forAllContexts wordCase (contexts s)
    where
    wordCase c = I.fromList q c $ limitWords s $ IDX.prefixCase (index s) c q
  
  -- | Monadic version of 'processCaseWord'.
  
  processCaseWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate
  processCaseWordM s q = forAllContextsM wordCase (contexts s)
    where
    wordCase c = IDX.prefixCaseM (index s) c q >>= limitWordsM s >>= \r -> return $ I.fromList q c r
  
  -- | Process a phrase case-insensitive.
  
  processPhrase :: HolIndex i => ProcessState i -> String -> Intermediate
  processPhrase s q = forAllContexts phraseNoCase (contexts s)
    where
    phraseNoCase c = processPhraseInternal (IDX.lookupNoCase (index s) c) c q
  
  -- processPhraseM :: HolIndexM m i => ProcessState i -> String -> m Intermediate
  -- processPhraseM s q = forAllContextsM phraseNoCase (contexts s)
  --   where
  --   phraseNoCase c = 
  
  -- | Process a phrase case-sensitive.
  
  processCasePhrase :: HolIndex i => ProcessState i -> String -> Intermediate
  processCasePhrase s q = forAllContexts phraseCase (contexts s)
    where
    phraseCase c = processPhraseInternal (IDX.lookupCase (index s) c) c q
  
  -- | Process a phrase query by searching for every word of the phrase and comparing their positions.
  
  processPhraseInternal :: (String -> RawResult) -> Context -> String -> Intermediate
  processPhraseInternal f c q = let
    w = words q 
    m = mergeOccurrencesList $ map snd $ f (head w) in
    if nullDocIdMap m
    then I.emptyIntermediate
    else I.fromList q c [(q, processPhrase' (tail w) 1 m)]
    where
    processPhrase' :: [String] -> Position -> Occurrences -> Occurrences
    processPhrase' [] _ o = o
    processPhrase' (x:xs) p o = processPhrase' xs (p+1) (filterWithKeyDocIdMap (nextWord $ map snd $ f x) o)
      where
        nextWord :: [Occurrences] -> DocId -> Positions -> Bool
        nextWord [] _ _  = False
        nextWord no d np = maybe False hasSuccessor (lookupDocIdMap d (mergeOccurrencesList no))
            where
              hasSuccessor :: Positions -> Bool
              hasSuccessor w = foldPos (\cp r -> r || (memberPos (cp + p) w)) False np
  
  -- | Process a single word and try some fuzzy alternatives if nothing was found.
  
  processFuzzyWord :: HolIndex i => ProcessState i -> String -> Intermediate
  processFuzzyWord s oq = processFuzzyWord' (F.toList $ F.fuzz (getFuzzyConfig s) oq) (processWord s oq)
    where
    processFuzzyWord' :: [(String, FuzzyScore)] -> Intermediate -> Intermediate
    processFuzzyWord' []     r = r
    processFuzzyWord' (q:qs) r = if I.null r then processFuzzyWord' qs (processWord s (fst q)) else r
  
  -- | Monadic version of 'processFuzzyWord'.
  
  processFuzzyWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate
  processFuzzyWordM s oq = do
    sr <- processWordM s oq 
    cfg <- getFuzzyConfigM s
    processFuzzyWordM' (F.toList $ F.fuzz cfg oq) sr
      where
      processFuzzyWordM' []     r = return r
      processFuzzyWordM' (q:qs) r = if I.null r
                                    then processWordM s (fst q) >>= processFuzzyWordM' qs
                                    else return r
  
  -- | Process a negation by getting all documents and substracting the result of the negated query.
  
  processNegation :: HolIndex i => ProcessState i -> Intermediate -> Intermediate
  processNegation s r = I.difference (allDocuments s) r
  
  -- | Monadic version of 'processNegation'.
  
  processNegationM :: HolIndexM m i => ProcessState i -> Intermediate -> m Intermediate
  processNegationM s r1 = allDocumentsM s >>= \r2 -> return $ I.difference r2 r1
  
  -- | Process a binary operator by caculating the union or the intersection of the two subqueries.
  
  processBin :: BinOp -> Intermediate -> Intermediate -> Intermediate
  processBin And r1 r2 = I.intersection r1 r2
  processBin Or r1 r2  = I.union r1 r2
  processBin But r1 r2 = I.difference r1 r2
  
  
  -- | Limit a 'RawResult' to a fixed amount of the best words.
  --
  -- First heuristic applied is limiting the number of documents in the result,
  -- assuming the short words come first in the result list
  -- So the length of the result list depends on the number of documents found.
  --
  -- TODO: This is fixed to 2000, should be part of the config part of the state
  --
  -- A 2. simple heuristic is used to 
  -- determine the quality of a word: The total number of occurrences divided by the number of 
  -- documents in which the word appears.
  --
  -- The second heuristic isn't that expensive any more when the resul list is cut of by the heuristic
  --
  -- The limit 500 should be part of a configuration
  
  limitWords              :: ProcessState i -> RawResult -> RawResult
  limitWords s r          = cutW . cutD $ r
    where
    limitD                = docLimit $ config s
    cutD
        | limitD > 0      = limitDocs limitD
        | otherwise       = id
  
    limitW                = wordLimit $ config s
    cutW
        | limitW > 0
          &&
          length r > limitW
                          = map snd . take limitW . L.sortBy (compare `on` fst) . map calcScore
        | otherwise       = id
  
    calcScore             :: (Word, Occurrences) -> (Double, (Word, Occurrences))
    calcScore w@(_, o)    = (log (fromIntegral (total s) / fromIntegral (sizeDocIdMap o)), w)
  
  -- ----------------------------------------------------------------------------
  
  -- | Limit the number of docs in a raw result
  
  limitDocs               :: Int -> RawResult -> RawResult
  limitDocs _     []      = []
  limitDocs limit _
      | limit <= 0        = []
  limitDocs limit (x:xs)  = x : limitDocs (limit - sizeDocIdMap (snd x)) xs
  
  -- ----------------------------------------------------------------------------
  
  -- | Monadic version of 'limitWords'.
  limitWordsM             :: (Monad m) => ProcessState i -> RawResult -> m RawResult
  limitWordsM s r         = return $ limitWords s r
  
  -- | Merge occurrences
  mergeOccurrencesList    :: [Occurrences] -> Occurrences
  mergeOccurrencesList    = unionsWithDocIdMap unionPos
  
  -- ----------------------------------------------------------------------------
  