Condition.hsc

{-# LANGUAGE
    EmptyDataDecls
  , ForeignFunctionInterface
  , UnicodeSyntax
  #-}

#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 qualified Data.Text as T
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Prelude.Unicode
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 → T.Text → 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 → T.Text → 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 → T.Text → 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 → T.Text → 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