#include "estraier.h"

{-# OPTIONS_HADDOCK prune #-}

-- |An interface to functions to manipulate search conditions.

module Text.HyperEstraier.Condition
    ( -- * Types
      Condition
    , ESTCOND -- private
    , CondOption(..)
    , SearchSpeed(..)
    , SyntaxType(..)
    , Eclipse(..)

    , withCondPtr -- private

      -- * Manipulating conditions
    , newCondition
    , setPhrase
    , addAttrCond
    , setOrder
    , setMax
    , setSkip
    , setOptions
    , setAuxiliary
    , setEclipse
    , setDistinct
    , setMetaSearchMask
    )
    where

import           Control.Exception
import           Data.Bits
import           Foreign.C.String
import           Foreign.C.Types
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Text.HyperEstraier.Utils

-- |'Condition' is an opaque object representing a search condition.
newtype Condition = Condition (ForeignPtr ESTCOND)
data ESTCOND

-- |'CondOption' is an option to the search condition.
data CondOption
    = Speed SearchSpeed -- ^ Choose a @'SearchSpeed'@.
    | OmitTFIDF         -- ^ Omit calculating TF-IDF weight.
    | Syntax SyntaxType -- ^ Choose a @'SyntaxType'@.
    deriving (Eq, Show)

-- |'SearchSpeed' is an option to the search condition.
data SearchSpeed
    = Slow       -- ^ Search for all N-gram keys.
    | Normal     -- ^ Search for N-gram keys alternately.
    | Fast       -- ^ Search for N-gram keys by skipping 2\/3 of them.
    | EvenFaster -- ^ Search for N-gram keys by skipping 3\/4 of them.
    deriving (Eq, Show)

-- |'SyntaxType' is an option to the search condition.
data SyntaxType
    = Simplified   -- ^ Interpret the condition phrase as the
                   --   simplified syntax. See the user's guide of the
                   --   HyperEstraier for explanation about the
                   --   simplified syntax.
    | Rough        -- ^ Interpret the condition phrase as the rough
                   --   syntax. See the user's guide for details.
    | Union        -- ^ Interpret the condition phrase as the union
                   --   syntax. See the user's guide for details.
    | Intersection -- ^ Interpret the condition phrase as the
                   --   intersection syntax. See the user's guide for
                   --   details.
    deriving (Eq, Show)

marshalCondOption :: CondOption -> CInt
marshalCondOption (Speed Slow         ) = #const ESTCONDSURE
marshalCondOption (Speed Normal       ) = #const ESTCONDUSUAL
marshalCondOption (Speed Fast         ) = #const ESTCONDFAST
marshalCondOption (Speed EvenFaster   ) = #const ESTCONDAGITO
marshalCondOption OmitTFIDF             = #const ESTCONDNOIDF
marshalCondOption (Syntax Simplified  ) = #const ESTCONDSIMPLE
marshalCondOption (Syntax Rough       ) = #const ESTCONDROUGH
marshalCondOption (Syntax Union       ) = #const ESTCONDUNION
marshalCondOption (Syntax Intersection) = #const ESTCONDISECT

-- |'Eclipse' represents how to hide documents from the search
-- result by their similarity.
data Eclipse
    = Threshold Double -- ^ Threshold to cause eclipse to
                       --   documents. @'Threshold' x@ must satisfy
                       --   @0.0 <= x <= 1.0@.
    | ThresholdWithURL Double -- ^ This is similar to @'Threshold'@
                              -- but this specifies that the document
                              -- URI is also used to calculate the
                              -- similarity.
    | SameServer       -- ^ Cause eclipse to the documents on the same
                       --   server.
    | SameDirectory    -- ^ Cause eclipse to the documents in the same
                       --   directory.
    | SameFile         -- ^ Cause eclipse to the documents whose file
                       --   name is the same.
    deriving (Eq, Show)


marshalEclipse :: Eclipse -> CDouble
marshalEclipse (Threshold thr)        = assertThreshold (realToFrac thr)
marshalEclipse (ThresholdWithURL thr) = assertThreshold (realToFrac thr) + #const ESTECLSIMURL
marshalEclipse SameServer             = #const ESTECLSERV
marshalEclipse SameDirectory          = #const ESTECLDIR
marshalEclipse SameFile               = #const ESTECLFILE

assertThreshold :: (Fractional a, Ord a) => a -> a
assertThreshold thr = assert (thr >= 0.0 && thr <= 1.0) thr


foreign import ccall unsafe "estraier.h est_cond_new"
        _new :: IO (Ptr ESTCOND)

foreign import ccall unsafe "estraier.h &est_cond_delete"
        _delete :: FunPtr (Ptr ESTCOND -> IO ())

foreign import ccall unsafe "estraier.h est_cond_set_phrase"
        _set_phrase :: Ptr ESTCOND -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_cond_add_attr"
        _add_attr :: Ptr ESTCOND -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_order"
        _set_order :: Ptr ESTCOND -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_max"
        _set_max :: Ptr ESTCOND -> CInt -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_skip"
        _set_skip :: Ptr ESTCOND -> CInt -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_options"
        _set_options :: Ptr ESTCOND -> CInt -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_auxiliary"
        _set_auxiliary :: Ptr ESTCOND -> CInt -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_eclipse"
        _set_eclipse :: Ptr ESTCOND -> CDouble -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_distinct"
        _set_distinct :: Ptr ESTCOND -> CString -> IO ()

foreign import ccall unsafe "estraier.h est_cond_set_mask"
        _set_mask :: Ptr ESTCOND -> CInt -> IO ()


wrapCond :: Ptr ESTCOND -> IO Condition
wrapCond = fmap Condition . newForeignPtr _delete


withCondPtr :: Condition -> (Ptr ESTCOND -> IO a) -> IO a
withCondPtr (Condition cond) = withForeignPtr cond

-- |'newCondition' creates an empty search condition.
newCondition :: IO Condition
newCondition = _new >>= wrapCond

-- |@'setPhrase' cond phrase@ stores a condition phrase into
-- @cond@. The syntax of the phrase is assumed to be the normal
-- syntax, unless you specify a 'SyntaxType' explicitly with
-- 'setOptions'.
setPhrase :: Condition -> String -> IO ()
setPhrase cond phrase
    = withCondPtr     cond   $ \ condPtr   ->
      withUTF8CString phrase $
      _set_phrase condPtr

-- |@'addAttrCond' cond expr@ appends an attribute search condition to
-- @cond@. See the user's guide for explanation about the attribute
-- search condition.
addAttrCond :: Condition -> String -> IO ()
addAttrCond cond attr
    = withCondPtr     cond $ \ condPtr ->
      withUTF8CString attr $
      _add_attr condPtr

-- |@'setOrder' cond expr@ stores an ordering expression into
-- @cond@. See the user's guide for explanation about the ordering
-- expression. By default, the result is sorted in descending order of
-- score.
setOrder :: Condition -> String -> IO ()
setOrder cond order
    = withCondPtr     cond  $ \ condPtr  ->
      withUTF8CString order $
      _set_order condPtr

-- |@'setMax' cond n@ specifies the maximum number of results. By
-- default, the number of results is unlimited.
setMax :: Condition -> Int -> IO ()
setMax cond
    = withCondPtr cond . flip _set_max . fromIntegral

-- |@'setSkip' cond n@ specifies how many documents should be skipped
-- from the beginning of result.
setSkip :: Condition -> Int -> IO ()
setSkip cond
    = withCondPtr cond . flip _set_skip . fromIntegral

-- |@'setOptions' cond opts@ specifies options to the search
-- condition.
setOptions :: Condition -> [CondOption] -> IO ()
setOptions cond
    = withCondPtr cond .
      flip _set_options .
      marshalOpts marshalCondOption

-- |@'setAuxiliary' cond min@ specifies how many documents should be
-- in the result to avoid using the auxiliary index to pad the result.
setAuxiliary :: Condition -> Int -> IO ()
setAuxiliary cond
    = withCondPtr cond . flip _set_auxiliary . fromIntegral

-- |@'setEclipse' cond ecl@ specifies how to hide documents from the
-- search result by their similarity.
setEclipse :: Condition -> Eclipse -> IO ()
setEclipse cond
    = withCondPtr cond . flip _set_eclipse . marshalEclipse

-- |@'setDistinct' cond attr@ specifies an attribute which must be
-- unique to the search result.
setDistinct :: Condition -> String -> IO ()
setDistinct cond attr
    = withCondPtr     cond $ \ condPtr ->
      withUTF8CString attr $
      _set_distinct condPtr

-- |@'setMetaSearchMask' cond xs@ specifies that, in
-- 'Text.HyperEstraier.Database.metaSearch', some databases must be
-- excluded from the search result. e.g.
--
-- > main = withDatabase "db1" (Reader []) $ \ db1 ->
-- >        withDatabase "db2" (Reader []) $ \ db2 ->
-- >        withDatabase "db3" (Reader []) $ \ db3 ->
-- >        do cond <- newCondition
-- >           setPhrase cond "hello AND world"
-- >           setMetaSearchMask cond [0, 2] -- zero-origin
-- >
-- >           -- In this case, "db1" and "db3" are excluded from the meta search.
-- >           result <- metaSearch [db1, db2, db3] 
-- >           print result
--
setMetaSearchMask :: Condition -> [Int] -> IO ()
setMetaSearchMask cond
    = withCondPtr cond . flip _set_max . fromIntegral . calculateMask
    where
      calculateMask :: [Int] -> Int
      calculateMask []     = 0
      calculateMask (y:ys) = assert (y >= 0 && y <= 28)
                             $ (1 `shiftL` y) .|. calculateMask ys