Condition.hs

{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-}
{-# INCLUDE "estraier.h" #-}
{-# LINE 1 "Text/HyperEstraier/Condition.hsc" #-}

{-# LINE 2 "Text/HyperEstraier/Condition.hsc" #-}

-- #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.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 -> Int
marshalCondOption (Speed Slow         ) = (1)
{-# LINE 76 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Speed Normal       ) = (2)
{-# LINE 77 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Speed Fast         ) = (4)
{-# LINE 78 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Speed EvenFaster   ) = (8)
{-# LINE 79 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption OmitTFIDF             = (16)
{-# LINE 80 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Syntax Simplified  ) = (1024)
{-# LINE 81 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Syntax Rough       ) = (2048)
{-# LINE 82 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Syntax Union       ) = (32768)
{-# LINE 83 "Text/HyperEstraier/Condition.hsc" #-}
marshalCondOption (Syntax Intersection) = (65536)
{-# LINE 84 "Text/HyperEstraier/Condition.hsc" #-}

-- |'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 -> Double
marshalEclipse (Threshold thr)        = assertThreshold thr
marshalEclipse (ThresholdWithURL thr) = assertThreshold thr + (10)
{-# LINE 107 "Text/HyperEstraier/Condition.hsc" #-}
marshalEclipse SameServer             = (100)
{-# LINE 108 "Text/HyperEstraier/Condition.hsc" #-}
marshalEclipse SameDirectory          = (101)
{-# LINE 109 "Text/HyperEstraier/Condition.hsc" #-}
marshalEclipse SameFile               = (102)
{-# LINE 110 "Text/HyperEstraier/Condition.hsc" #-}

assertThreshold :: Double -> Double
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 -> Int -> IO ()

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

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

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

foreign import ccall unsafe "estraier.h est_cond_set_eclipse"
        _set_eclipse :: Ptr ESTCOND -> Double -> 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 -> Int -> IO ()


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


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 $ \ phrasePtr ->
      _set_phrase condPtr phrasePtr

-- |@'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 $ \ attrPtr ->
      _add_attr condPtr attrPtr

-- |@'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 $ \ orderPtr ->
      _set_order condPtr orderPtr

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

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

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

-- |@'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 n
    = withCondPtr cond $ \ condPtr ->
      _set_auxiliary condPtr n

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

-- |@'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 $ \ attrPtr ->
      _set_distinct condPtr attrPtr

-- |@'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 xs
    = withCondPtr cond $ \ condPtr ->
      _set_max condPtr (calculateMask xs)
    where
      calculateMask :: [Int] -> Int
      calculateMask []     = 0
      calculateMask (x:xs) = assert (x >= 0 && x <= 28)
                             $ (1 `shiftL` x) .|. calculateMask xs