diff --git a/Database/QDBM/Cabin/List.hs b/Database/QDBM/Cabin/List.hs deleted file mode 100644 --- a/Database/QDBM/Cabin/List.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# LINE 1 "Database/QDBM/Cabin/List.hsc" #-} -module Database.QDBM.Cabin.List -{-# LINE 2 "Database/QDBM/Cabin/List.hsc" #-} - ( List - , CBLIST - - , wrapList - , withListPtr - - , newList - , push - , length - , (!!) - - , toList - , fromList - ) - where - -import qualified Data.ByteString as BS -import Data.ByteString.Base -import Data.Maybe -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc -import Prelude hiding (length, (!!)) - - -infixl 9 !! - - -newtype List = List (ForeignPtr CBLIST) -data CBLIST - - -foreign import ccall unsafe "cabin.h cblistopen" - _open :: IO (Ptr CBLIST) - -foreign import ccall unsafe "cabin.h &cblistclose" - _close :: FunPtr (Ptr CBLIST -> IO ()) - -foreign import ccall unsafe "cabin.h cblistnum" - _num :: Ptr CBLIST -> IO CInt - -foreign import ccall unsafe "cabin.h cblistval" - _val :: Ptr CBLIST -> CInt -> Ptr CInt -> IO (Ptr CChar) - -foreign import ccall unsafe "cabin.h cblistpush" - _push :: Ptr CBLIST -> Ptr CChar -> CInt -> IO () - - -wrapList :: Ptr CBLIST -> IO List -wrapList listPtr = newForeignPtr _close listPtr >>= return . List - - -withListPtr :: List -> (Ptr CBLIST -> IO a) -> IO a -withListPtr (List list) = withForeignPtr list - - -newList :: IO List -newList = _open >>= wrapList - - -push :: List -> ByteString -> IO () -push list value - = withListPtr list $ \ listPtr -> - BS.useAsCStringLen value $ \ (valuePtr, valueLen) -> - _push listPtr valuePtr (fromIntegral valueLen) - - -length :: List -> IO Int -length list - = withListPtr list $ \ listPtr -> - _num listPtr >>= return . fromIntegral - - -(!!) :: List -> Int -> IO (Maybe ByteString) -list !! index - = withListPtr list $ \ listPtr -> - alloca $ \ valLenPtr -> - do valPtr <- _val listPtr (fromIntegral index) valLenPtr - if valPtr == nullPtr then - return Nothing - else - do valLen <- peek valLenPtr - value <- BS.copyCStringLen (valPtr, fromIntegral valLen) - return $ Just value - - -toList :: List -> IO [ByteString] -toList list - = do len <- length list - mapM (list !!) [0..len] >>= return . catMaybes - - -fromList :: [ByteString] -> IO List -fromList values - = do list <- newList - mapM_ (push list) values - return list diff --git a/Database/QDBM/Cabin/Map.hs b/Database/QDBM/Cabin/Map.hs deleted file mode 100644 --- a/Database/QDBM/Cabin/Map.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# LINE 1 "Database/QDBM/Cabin/Map.hsc" #-} -module Database.QDBM.Cabin.Map -{-# LINE 2 "Database/QDBM/Cabin/Map.hsc" #-} - ( Map - , CBMAP - - , wrapMap - , unsafePeekMap - , withMapPtr - - , newMap - , put - , get - - , toList - , fromList - ) - where - - -import qualified Data.ByteString as BS -import Data.ByteString.Base -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import Foreign.Marshal.Alloc - - -newtype Map = Map (ForeignPtr CBMAP) -data CBMAP - - -foreign import ccall unsafe "cabin.h cbmapopen" - _open :: IO (Ptr CBMAP) - -foreign import ccall unsafe "cabin.h &cbmapclose" - _close :: FunPtr (Ptr CBMAP -> IO ()) - -foreign import ccall unsafe "cabin.h cbmapput" - _put :: Ptr CBMAP -> Ptr CChar -> CInt -> Ptr CChar -> CInt -> CInt -> IO CInt - -foreign import ccall unsafe "cabin.h cbmapget" - _get :: Ptr CBMAP -> Ptr CChar -> CInt -> Ptr CInt -> IO (Ptr CChar) - -foreign import ccall unsafe "cabin.h cbmapiterinit" - _iterinit :: Ptr CBMAP -> IO () - -foreign import ccall unsafe "cabin.h cbmapiternext" - _iternext :: Ptr CBMAP -> Ptr CInt -> IO (Ptr CChar) - -foreign import ccall unsafe "cabin.h cbmapiterval" - _iterval :: Ptr CChar -> Ptr CInt -> IO (Ptr CChar) - - -wrapMap :: Ptr CBMAP -> IO Map -wrapMap mapPtr = newForeignPtr _close mapPtr >>= return . Map - - -unsafePeekMap :: Ptr CBMAP -> IO Map -unsafePeekMap mapPtr = newForeignPtr_ mapPtr >>= return . Map - - -withMapPtr :: Map -> (Ptr CBMAP -> IO a) -> IO a -withMapPtr (Map m) = withForeignPtr m - - -newMap :: IO Map -newMap = _open >>= wrapMap - - -put :: Map -> ByteString -> ByteString -> Bool -> IO Bool -put m key value overwrite - = withMapPtr m $ \ mapPtr -> - BS.useAsCStringLen key $ \ (keyPtr , keyLen ) -> - BS.useAsCStringLen value $ \ (valuePtr, valueLen) -> - _put mapPtr - keyPtr (fromIntegral keyLen ) - valuePtr (fromIntegral valueLen) - (fromIntegral $ fromEnum overwrite) - >>= return . (/= 0) - - -get :: Map -> ByteString -> IO (Maybe ByteString) -get m key - = withMapPtr m $ \ mapPtr -> - BS.useAsCStringLen key $ \ (keyPtr, keyLen) -> - alloca $ \ valLenPtr -> - do valPtr <- _get mapPtr keyPtr (fromIntegral keyLen) valLenPtr - if valPtr == nullPtr then - return Nothing - else - do valLen <- peek valLenPtr - value <- BS.copyCStringLen (valPtr, fromIntegral valLen) - return $ Just value - - -initIterator :: Map -> IO () -initIterator m - = withMapPtr m $ \ mapPtr -> - _iterinit mapPtr - - -iterateNext :: Map -> IO (Maybe (ByteString, ByteString)) -iterateNext m - = withMapPtr m $ \ mapPtr -> - alloca $ \ keyLenPtr -> - alloca $ \ valLenPtr -> - do keyPtr <- _iternext mapPtr keyLenPtr - if keyPtr == nullPtr then - return Nothing - else - do keyLen <- peek keyLenPtr - key <- BS.copyCStringLen (keyPtr, fromIntegral keyLen) - -- QDBM のソースを見たら、keyPtr そのものの値からアドレ - -- スを計算してゐた…。良くそんな無茶をやるなあと思ふ。 - valPtr <- _iterval keyPtr valLenPtr - valLen <- peek valLenPtr - value <- BS.copyCStringLen (valPtr, fromIntegral valLen) - return $ Just (key, value) - - --- iterator の状態は Map 内部に格納されるので、thread-safe でない。だか --- ら list にするなら正格にしなければならない。 -toList :: Map -> IO [(ByteString, ByteString)] -toList m = initIterator m >> loop - where - loop :: IO [(ByteString, ByteString)] - loop = do next <- iterateNext m - case next of - Nothing -> return [] - Just pair -> do rest <- loop -- ここで unsafeInterleaveIO したいが出來ない。 - return $ pair : rest - - -fromList :: [(ByteString, ByteString)] -> IO Map -fromList pairs - = do m <- newMap - mapM_ (putPair m) pairs - return m - where - putPair :: Map -> (ByteString, ByteString) -> IO () - putPair m (key, value) = put m key value True >> return () diff --git a/HsHyperEstraier.cabal b/HsHyperEstraier.cabal --- a/HsHyperEstraier.cabal +++ b/HsHyperEstraier.cabal @@ -5,16 +5,17 @@ Haskell. HyperEstraier is an embeddable full text search engine which is supposed to be independent to any particular natural languages. -Version: 0.2 +Version: 0.2.1 License: PublicDomain License-File: COPYING -Author: PHO -Maintainer: PHO +Author: PHO +Maintainer: PHO Stability: experimental Homepage: http://ccm.sherry.jp/HsHyperEstraier/ Category: Text Tested-With: GHC == 6.8.1 Cabal-Version: >= 1.2 +Build-Type: Simple Extra-Source-Files: NEWS @@ -36,7 +37,7 @@ Database.QDBM.Cabin.Map Text.HyperEstraier.Utils Extensions: - EmptyDataDecls, ForeignFunctionInterface + DeriveDataTypeable, EmptyDataDecls, ForeignFunctionInterface GHC-Options: - -Wall -XDeriveDataTypeable + -Wall diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,7 @@ +Changes from 0.2 to 0.2.1 +------------------------- +* Only changes to various meta-data; no semantical changes to the code itself. + Changes from 0.1 to 0.2 ----------------------- * HsHyperEstraier now requires GHC 6.8.1 diff --git a/Text/HyperEstraier/Condition.hs b/Text/HyperEstraier/Condition.hs deleted file mode 100644 --- a/Text/HyperEstraier/Condition.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# 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 diff --git a/Text/HyperEstraier/Database.hs b/Text/HyperEstraier/Database.hs deleted file mode 100644 --- a/Text/HyperEstraier/Database.hs +++ /dev/null @@ -1,727 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# INCLUDE "estraier.h" #-} -{-# LINE 1 "Text/HyperEstraier/Database.hsc" #-} - -{-# LINE 2 "Text/HyperEstraier/Database.hsc" #-} - --- |An interface to functions to manipulate databases. - -module Text.HyperEstraier.Database - ( -- * Types - Database - , EstError(..) - - , AttrIndexType(..) - , OptimizeOption(..) - , RemoveOption(..) - , PutOption(..) - , GetOption(..) - - , OpenMode(..) - , ReaderOption(..) - , WriterOption(..) - , LockingMode(..) - , CreateOption(..) - , AnalysisOption(..) - , IndexTuning(..) - , ScoreOption(..) - - -- * Opening and closing databases - , withDatabase - , openDatabase - , closeDatabase - - -- * Manipulating database - , addAttrIndex - , flushDatabase - , syncDatabase - , optimizeDatabase - , mergeDatabase - , setCacheSize - - -- * Getting documents in and out - , putDocument - , removeDocument - , updateDocAttrs - , getDocument - , getDocAttr - , getDocURI - , getDocIdByURI - - -- * Statistics of databases - , getDatabaseName - , getNumOfDocs - , getNumOfWords - , getDatabaseSize - , hasFatalError - - -- * Searching for documents - , searchDatabase - , searchDatabase' - , metaSearch - , metaSearch' - , scanDocument - ) - where - -import Control.Exception -import Control.Monad -import Data.Bits -import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Base -import Data.Encoding -import Data.Encoding.UTF8 -import Data.Dynamic -import Data.IORef -import Data.Maybe -import Data.Typeable -import qualified Database.QDBM.Cabin.Map as CM -import Foreign.C.String -import Foreign.C.Types -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable -import Network.URI -import Text.HyperEstraier.Condition -import Text.HyperEstraier.Document -import Text.HyperEstraier.Utils - --- |'EstError' represents an error occured on various operations. It --- is usually thrown as a 'Control.Exception.DynException'. -data EstError - = InvalidArgument -- ^ An argument passed to the function was invalid. - | AccessForbidden -- ^ The operation is forbidden. - | LockFailure -- ^ Failed to lock the database. - | DatabaseProblem -- ^ The database has a problem. - | IOProblem -- ^ An I\/O operation failed. - | NoSuchItem -- ^ An object you specified does not exist. - | MiscError -- ^ Errors for other reasons. - deriving (Eq, Show, Typeable) - - -unmarshalError :: Int -> EstError -unmarshalError (1) = InvalidArgument -{-# LINE 101 "Text/HyperEstraier/Database.hsc" #-} -unmarshalError (2) = AccessForbidden -{-# LINE 102 "Text/HyperEstraier/Database.hsc" #-} -unmarshalError (3) = LockFailure -{-# LINE 103 "Text/HyperEstraier/Database.hsc" #-} -unmarshalError (4) = DatabaseProblem -{-# LINE 104 "Text/HyperEstraier/Database.hsc" #-} -unmarshalError (5) = IOProblem -{-# LINE 105 "Text/HyperEstraier/Database.hsc" #-} -unmarshalError (6) = NoSuchItem -{-# LINE 106 "Text/HyperEstraier/Database.hsc" #-} -unmarshalError (9999) = MiscError -{-# LINE 107 "Text/HyperEstraier/Database.hsc" #-} - --- |'OpenMode' represents how to open a database. -data OpenMode - = Reader [ReaderOption] -- ^ Open the database with read-only - -- mode. You can specify 'ReaderOption' - -- to modify the behavior of the - -- database. - | Writer [WriterOption] -- ^ Open the database with writable - -- mode. You can specify 'WriterOption' - -- to modify the behavior of the - -- database. - deriving (Eq, Show) - --- |'ReaderOption' is an option for the 'Reader' constructor. -data ReaderOption - = ReadLock LockingMode -- ^ Specify how to lock the database. - deriving (Eq, Show) - --- |'WriterOption' is an option for the 'Writer' constructor. -data WriterOption - = Create [CreateOption] -- ^ Create a database if an old one - -- doesn't exist. You can specify - -- 'CreateOption' to modify the - -- behavior of the database. - | Truncate [CreateOption] -- ^ Always create a new database even - -- if an old one already exists. You - -- can specify 'CreateOption' to - -- modify the behavior of the - -- database. - | WriteLock LockingMode -- ^ Specify how to lock the database. - deriving (Eq, Show) - --- |'LockingMode' represents how to lock the database. -data LockingMode - = NoLock -- ^ Do no exclusive access control at all. This - -- option is very unsafe. - | NonblockingLock -- ^ Do non-blocking lock. (The author of this - -- module doesn't know what happens if this - -- option is in effect. See the manual and the - -- source code of HyperEstraier and QDBM.) - deriving (Eq, Show) - --- |'CreateOption' is an option for the 'Create' constructor. -data CreateOption - = Analysis AnalysisOption -- ^ Specify the word analysis method. - | Index IndexTuning -- ^ Specify the prospective size of the - -- database. - | Score [ScoreOption] -- ^ Specify how to handle scores of the - -- documents. - deriving (Eq, Show) - --- |'AnalysisOption' is an option for the 'Analysis' constructor. -data AnalysisOption - = PerfectNGram -- ^ Use the perfect N-gram analyzer. - | CharCategory -- ^ Use the character category analyzer. - deriving (Eq, Show) - --- |'IndexTuning' is an option for the 'Index' constructor. -data IndexTuning - = Small -- ^ Predict the database will have less than 50,000 - -- documents. - | Large -- ^ Predict the database will have less than 300,000 - -- documents. - | Huge -- ^ Predict the database will have less than 1,000,000 - -- documents. - | Huge2 -- ^ Predict the database will have less than 5,000,000 - -- documents. - | Huge3 -- ^ Predict the database will have more than 10,000,000 - -- documents. - deriving (Eq, Show) - --- |'ScoreOption' is an option for the 'Score' constructor. -data ScoreOption - = Nullified -- ^ Nullify anything about the score of - -- documents. - | StoredAsInt -- ^ Store the scores for documents into the - -- database as 32-bit integer. - | OnlyToBeStored -- ^ Store the scores for documents into the - -- database but don't use them during the - -- search operation. - deriving (Eq, Show) - - -marshalOpenMode :: OpenMode -> Int -marshalOpenMode (Reader opts) = (1) .|. marshalOpts marshalReaderOption opts -{-# LINE 192 "Text/HyperEstraier/Database.hsc" #-} -marshalOpenMode (Writer opts) = (2) .|. marshalOpts marshalWriterOption opts -{-# LINE 193 "Text/HyperEstraier/Database.hsc" #-} - -marshalReaderOption :: ReaderOption -> Int -marshalReaderOption (ReadLock mode) = marshalLockingMode mode - -marshalWriterOption :: WriterOption -> Int -marshalWriterOption (Create opts) = (4) .|. marshalOpts marshalCreateOption opts -{-# LINE 199 "Text/HyperEstraier/Database.hsc" #-} -marshalWriterOption (Truncate opts) = (8) .|. marshalOpts marshalCreateOption opts -{-# LINE 200 "Text/HyperEstraier/Database.hsc" #-} -marshalWriterOption (WriteLock mode) = marshalLockingMode mode - -marshalLockingMode :: LockingMode -> Int -marshalLockingMode NoLock = (16) -{-# LINE 204 "Text/HyperEstraier/Database.hsc" #-} -marshalLockingMode NonblockingLock = (32) -{-# LINE 205 "Text/HyperEstraier/Database.hsc" #-} - -marshalCreateOption :: CreateOption -> Int -marshalCreateOption (Analysis opt ) = marshalAnalysisOption opt -marshalCreateOption (Index tuning) = marshalIndexTuning tuning -marshalCreateOption (Score opts ) = marshalOpts marshalScoreOption opts - -marshalAnalysisOption :: AnalysisOption -> Int -marshalAnalysisOption PerfectNGram = (1024) -{-# LINE 213 "Text/HyperEstraier/Database.hsc" #-} -marshalAnalysisOption CharCategory = (2048) -{-# LINE 214 "Text/HyperEstraier/Database.hsc" #-} - -marshalIndexTuning :: IndexTuning -> Int -marshalIndexTuning Small = (1048576) -{-# LINE 217 "Text/HyperEstraier/Database.hsc" #-} -marshalIndexTuning Large = (2097152) -{-# LINE 218 "Text/HyperEstraier/Database.hsc" #-} -marshalIndexTuning Huge = (4194304) -{-# LINE 219 "Text/HyperEstraier/Database.hsc" #-} -marshalIndexTuning Huge2 = (8388608) -{-# LINE 220 "Text/HyperEstraier/Database.hsc" #-} -marshalIndexTuning Huge3 = (16777216) -{-# LINE 221 "Text/HyperEstraier/Database.hsc" #-} - -marshalScoreOption :: ScoreOption -> Int -marshalScoreOption Nullified = (33554432) -{-# LINE 224 "Text/HyperEstraier/Database.hsc" #-} -marshalScoreOption StoredAsInt = (67108864) -{-# LINE 225 "Text/HyperEstraier/Database.hsc" #-} -marshalScoreOption OnlyToBeStored = (134217728) -{-# LINE 226 "Text/HyperEstraier/Database.hsc" #-} - --- |'AttrIndexType' represents an index type for an attribute. -data AttrIndexType - = SeqIndex -- ^ Map from a document ID to an attribute value. This - -- type of index increses the efficiency of, say, - -- 'getDocAttr'. - | StrIndex -- ^ Map from an attribute value to a document ID. This - -- increases the search speed when you search for - -- documents by an attribute value. - | NumIndex -- ^ This is similar to 'StrIndex' but for attributes - -- whose value is a number. - deriving (Eq, Show) - - -marshalAttrIndexType :: AttrIndexType -> Int -marshalAttrIndexType SeqIndex = (0) -{-# LINE 242 "Text/HyperEstraier/Database.hsc" #-} -marshalAttrIndexType StrIndex = (1) -{-# LINE 243 "Text/HyperEstraier/Database.hsc" #-} -marshalAttrIndexType NumIndex = (2) -{-# LINE 244 "Text/HyperEstraier/Database.hsc" #-} - --- |'OptimizeOption' is an option for the 'optimizeDatabase' action. -data OptimizeOption - = NoPurge -- ^ Omit the process which purges garbages of - -- removed documents. - | NoDBOptimize -- ^ Omit the process which optimizes the database - -- file. - deriving (Eq, Show) - - -marshalOptimizeOption :: OptimizeOption -> Int -marshalOptimizeOption NoPurge = (1) -{-# LINE 256 "Text/HyperEstraier/Database.hsc" #-} -marshalOptimizeOption NoDBOptimize = (2) -{-# LINE 257 "Text/HyperEstraier/Database.hsc" #-} - --- |'RemoveOption' is an option for the 'mergeDatabase' action and the --- 'removeDocument' action. -data RemoveOption - = CleaningRemove -- ^ Clean up the region in the database where - -- the removed documents were placed. - deriving (Eq, Show) - - -marshalRemoveOption :: RemoveOption -> Int -marshalRemoveOption CleaningRemove = (1) -{-# LINE 268 "Text/HyperEstraier/Database.hsc" #-} - --- |'PutOption' is an option for the 'putDocument' action. -data PutOption - = CleaningPut -- ^ If the new document overwrites an old one, - -- clean up the region in the database where - -- the old document were placed. - | WeightStatically -- ^ Statically apply the \"\@weight\" - -- attribute of the document. - deriving (Eq, Show) - - -marshalPutOption :: PutOption -> Int -marshalPutOption CleaningPut = (1) -{-# LINE 281 "Text/HyperEstraier/Database.hsc" #-} -marshalPutOption WeightStatically = (2) -{-# LINE 282 "Text/HyperEstraier/Database.hsc" #-} - --- |'GetOption' is an option for the 'getDocument' action. -data GetOption - = NoAttributes -- ^ Don't retrieve the attributes of the document. - | NoText -- ^ Don't retrieve the body of the document. - | NoKeywords -- ^ Don't retrieve the keywords of the document. - deriving (Eq, Show) - -marshalGetOption :: GetOption -> Int -marshalGetOption NoAttributes = (1) -{-# LINE 292 "Text/HyperEstraier/Database.hsc" #-} -marshalGetOption NoText = (2) -{-# LINE 293 "Text/HyperEstraier/Database.hsc" #-} -marshalGetOption NoKeywords = (4) -{-# LINE 294 "Text/HyperEstraier/Database.hsc" #-} - --- |@'Database'@ is an opaque object representing a HyperEstraier --- database. -newtype Database = Database (IORef (Ptr ESTMTDB)) -data ESTMTDB - - -foreign import ccall unsafe "estmtdb.h est_mtdb_open" - _open :: CString -> Int -> Ptr Int -> IO (Ptr ESTMTDB) - -foreign import ccall unsafe "estmtdb.h est_mtdb_close" - _close :: Ptr ESTMTDB -> Ptr Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_error" - _error :: Ptr ESTMTDB -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_fatal" - _fatal :: Ptr ESTMTDB -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_add_attr_index" - _add_attr_index :: Ptr ESTMTDB -> CString -> Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_flush" - _flush :: Ptr ESTMTDB -> Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_sync" - _sync :: Ptr ESTMTDB -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_optimize" - _optimize :: Ptr ESTMTDB -> Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_merge" - _merge :: Ptr ESTMTDB -> CString -> Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_put_doc" - _put_doc :: Ptr ESTMTDB -> Ptr ESTDOC -> Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_out_doc" - _out_doc :: Ptr ESTMTDB -> Int -> Int -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_edit_doc" - _edit_doc :: Ptr ESTMTDB -> Ptr ESTDOC -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_get_doc" - _get_doc :: Ptr ESTMTDB -> Int -> Int -> IO (Ptr ESTDOC) - -foreign import ccall unsafe "estmtdb.h est_mtdb_get_doc_attr" - _get_doc_attr :: Ptr ESTMTDB -> Int -> CString -> IO CString - -foreign import ccall unsafe "estmtdb.h est_mtdb_uri_to_id" - _uri_to_id :: Ptr ESTMTDB -> CString -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_name" - _name :: Ptr ESTMTDB -> IO CString - -foreign import ccall unsafe "estmtdb.h est_mtdb_doc_num" - _doc_num :: Ptr ESTMTDB -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_word_num" - _word_num :: Ptr ESTMTDB -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_size" - _size :: Ptr ESTMTDB -> IO Double - -foreign import ccall unsafe "estmtdb.h est_mtdb_search" - _search :: Ptr ESTMTDB -> Ptr ESTCOND -> Ptr Int -> Ptr CM.CBMAP -> IO (Ptr Int) - -foreign import ccall unsafe "estmtdb.h est_mtdb_search_meta" - _search_meta :: Ptr (Ptr ESTMTDB) -> Int -> Ptr ESTCOND -> Ptr Int -> Ptr CM.CBMAP -> IO (Ptr Int) - -foreign import ccall unsafe "estmtdb.h est_mtdb_scan_doc" - _scan_doc :: Ptr ESTMTDB -> Ptr ESTDOC -> Ptr ESTCOND -> IO Int - -foreign import ccall unsafe "estmtdb.h est_mtdb_set_cache_size" - _set_cache_size :: Ptr ESTMTDB -> CSize -> Int -> Int -> Int -> IO () - - -wrapDB :: Ptr ESTMTDB -> IO Database -wrapDB dbPtr = newIORef dbPtr >>= return . Database - - -throwEstError :: EstError -> IO a -throwEstError = throwIO . DynException . toDyn - - -withDBPtr :: Database -> (Ptr ESTMTDB -> IO a) -> IO a -withDBPtr (Database ref) f - = do dbPtr <- readIORef ref - if dbPtr == nullPtr then - fail "The HyperEstraier DB has already been closed." - else - f dbPtr - --- |@'withDatabase' fpath mode f@ opens a database at @fpath@ and --- compute @f@. When the action @f@ finishes or throws an exception, --- the database will be closed automatically. If 'withDatabase' fails --- to open the database, it throws an 'EstError'. See 'openDatabase'. -withDatabase :: FilePath -> OpenMode -> (Database -> IO a) -> IO a -withDatabase fpath opts f = bracket openDB' closeDatabase f - where - openDB' :: IO Database - openDB' = do ret <- openDatabase fpath opts - case ret of - Left err -> throwEstError err - Right db -> return db - --- |@'openDatabase' fpath mode@ opens a database at @fpath@. If it --- succeeds it returns @'Prelude.Right' 'Database'@, otherwise it --- returns @'Prelude.Left' 'EstError'@. --- --- The 'Database' can be shared by multiple threads, but there is one --- important limitation in the current implementation of the --- HyperEstraier itself. /A single process can NOT open the same --- database twice simultaneously./ Such attempt results in --- 'AccessForbidden'. -openDatabase :: FilePath -> OpenMode -> IO (Either EstError Database) -openDatabase fpath opts - = withUTF8CString fpath $ \ fpathPtr -> - alloca $ \ errPtr -> - do dbPtr <- _open fpathPtr (marshalOpenMode opts) errPtr - if dbPtr == nullPtr then - peek errPtr >>= return . Left . unmarshalError - else - wrapDB dbPtr >>= return . Right - --- |@'closeDatabase' db@ closes the database @db@. If the @db@ has --- already been closed, this operation causes nothing. -closeDatabase :: Database -> IO () -closeDatabase (Database ref) - = do dbPtr <- readIORef ref - when (dbPtr /= nullPtr) (close' dbPtr) - where - close' :: Ptr ESTMTDB -> IO () - close' dbPtr - = alloca $ \ errPtr -> - do ret <- _close dbPtr errPtr - case ret of - 0 -> peek errPtr >>= throwEstError . unmarshalError - _ -> writeIORef ref nullPtr - - -throwLastError :: Database -> IO a -throwLastError db - = withDBPtr db $ \ dbPtr -> - _error dbPtr >>= throwEstError . unmarshalError - - -throwLastErrorIf :: Database -> Bool -> IO () -throwLastErrorIf _ False = return () -throwLastErrorIf db True = throwLastError db - --- |Return 'Prelude.True' iff the document has a fatal error. -hasFatalError :: Database -> IO Bool -hasFatalError db - = withDBPtr db $ \ dbPtr -> - _fatal dbPtr >>= return . (/= 0) - --- |@'addAttrIndex' db attr idxType@ creates an index of type --- @idxType@ for attribute @attr@ into the database @db@. -addAttrIndex :: Database -> String -> AttrIndexType -> IO () -addAttrIndex db attr idxType - = withDBPtr db $ \ dbPtr -> - withUTF8CString attr $ \ attrPtr -> - _add_attr_index dbPtr attrPtr (marshalAttrIndexType idxType) - >>= throwLastErrorIf db . (== 0) - --- |@'flushDatabase' db numWords@ flushes at most @numWords@ index --- words in the cache of the database @db@. If @numWords <= 0@ all the --- index words will be flushed. -flushDatabase :: Database -> Int -> IO () -flushDatabase db maxWords - = withDBPtr db $ \ dbPtr -> - _flush dbPtr maxWords - >>= throwLastErrorIf db . (== 0) - --- |Synchronize a database to the disk. -syncDatabase :: Database -> IO () -syncDatabase db - = withDBPtr db $ \ dbPtr -> - _sync dbPtr - >>= throwLastErrorIf db . (== 0) - --- |Optimize a database. -optimizeDatabase :: Database -> [OptimizeOption] -> IO () -optimizeDatabase db opts - = withDBPtr db $ \ dbPtr -> - _optimize dbPtr (marshalOpts marshalOptimizeOption opts) - >>= throwLastErrorIf db . (== 0) - --- |@'mergeDatabase' db fpath opts@ merges another database at @fpath@ --- (source) to the @db@ (destination). The flags of the two databases --- must be the same. If any documents in the source database have the --- same URI as the documents in the destination, those documents in --- the destination will be overwritten. -mergeDatabase :: Database -> FilePath -> [RemoveOption] -> IO () -mergeDatabase db fpath opts - = withDBPtr db $ \ dbPtr -> - withUTF8CString fpath $ \ fpathPtr -> - _merge dbPtr fpathPtr (marshalOpts marshalRemoveOption opts) - >>= throwLastErrorIf db . (== 0) - --- |Put a document into a database. The document must have an --- @\"\@uri\"@ attribute. If the database already has a document whose --- URI is the same as of the new document, the old one will be --- overwritten. See 'Text.HyperEstraier.Document.setURI' and --- 'updateDocAttrs'. -putDocument :: Database -> Document -> [PutOption] -> IO () -putDocument db doc opts - = withDBPtr db $ \ dbPtr -> - withDocPtr doc $ \ docPtr -> - _put_doc dbPtr docPtr (marshalOpts marshalPutOption opts) - >>= throwLastErrorIf db . (== 0) - --- |Remove a document from a database. -removeDocument :: Database -> DocumentID -> [RemoveOption] -> IO () -removeDocument db docId opts - = withDBPtr db $ \ dbPtr -> - _out_doc dbPtr docId (marshalOpts marshalRemoveOption opts) - >>= throwLastErrorIf db . (== 0) - --- |Update attributes of a document in a database. The document to be --- updated is determined by the document ID. It is an error to change --- the URI of the document to be the same as of one of existing --- documents. Note that the document body will not be updated. See --- 'putDocument'. -updateDocAttrs :: Database -> Document -> IO () -updateDocAttrs db doc - = withDBPtr db $ \ dbPtr -> - withDocPtr doc $ \ docPtr -> - _edit_doc dbPtr docPtr - >>= throwLastErrorIf db . (== 0) - --- |Find a document in a database by an ID. -getDocument :: Database -> DocumentID -> [GetOption] -> IO Document -getDocument db docId opts - = withDBPtr db $ \ dbPtr -> - do docPtr <- _get_doc dbPtr docId (marshalOpts marshalGetOption opts) - throwLastErrorIf db (docPtr == nullPtr) - wrapDoc docPtr - --- |Get an attribute of a document in a database. -getDocAttr :: Database -> DocumentID -> String -> IO (Maybe String) -getDocAttr db docId name - = withDBPtr db $ \ dbPtr -> - withUTF8CString name $ \ namePtr -> - do valuePtr <- _get_doc_attr dbPtr docId namePtr - if valuePtr == nullPtr then - return Nothing - else - packMallocUTF8CString valuePtr >>= return . Just - --- |Get the URI of a document in a database. -getDocURI :: Database -> DocumentID -> IO URI -getDocURI db docId - = getDocAttr db docId "@uri" >>= return . fromJust . parseURI . fromJust - --- |Find a document in a database by an URI and return its ID. -getDocIdByURI :: Database -> URI -> IO (Maybe DocumentID) -getDocIdByURI db uri - = withDBPtr db $ \ dbPtr -> - withUTF8CString (uriToString id uri "") $ \ uriPtr -> - do ret <- _uri_to_id dbPtr uriPtr - case ret of - -1 -> return Nothing - _ -> return (Just ret) - --- |Get the name of a database. -getDatabaseName :: Database -> IO String -getDatabaseName db - = withDBPtr db $ \ dbPtr -> - _name dbPtr - >>= copyUTF8CString - --- |Get the number of documents in a database. -getNumOfDocs :: Database -> IO Int -getNumOfDocs db - = withDBPtr db $ \ dbPtr -> - _doc_num dbPtr - --- |Get the number of words in a database. -getNumOfWords :: Database -> IO Int -getNumOfWords db - = withDBPtr db $ \ dbPtr -> - _word_num dbPtr - --- |Get the size of a database. -getDatabaseSize :: Database -> IO Integer -getDatabaseSize db - = withDBPtr db $ \ dbPtr -> - -- なんで est_db_size() の戻り値が double なの。なんで size_t と - -- か long long int とかぢゃないの。H.E. のやってる事は大雜把には - -- 凄いのに、細かい部分が實に好い加減だなあ… - _size dbPtr >>= return . floor - --- |Search for documents in a database by a condition. -searchDatabase :: Database -> Condition -> IO [DocumentID] -searchDatabase db cond - = withDBPtr db $ \ dbPtr -> - withCondPtr cond $ \ condPtr -> - alloca $ \ retLenPtr -> - do retPtr <- _search dbPtr condPtr retLenPtr nullPtr - retLen <- peek retLenPtr - ret <- peekArray retLen retPtr - free retPtr - return ret - --- |Search for documents in a database by a condition. The second item --- of the resulting tuple is a map from each search words to the --- number of documents which are matched to the word. -searchDatabase' :: Database -> Condition -> IO ([DocumentID], [(String, Int)]) -searchDatabase' db cond - = do hints <- CM.newMap - withDBPtr db $ \ dbPtr -> - withCondPtr cond $ \ condPtr -> - alloca $ \ retLenPtr -> - CM.withMapPtr hints $ \ hintsPtr -> - do retPtr <- _search dbPtr condPtr retLenPtr hintsPtr - retLen <- peek retLenPtr - ret <- peekArray retLen retPtr - free retPtr - hints' <- liftM (map decodeHint) (CM.toList hints) - return (ret, hints') - - -decodeHint :: (ByteString, ByteString) -> (String, Int) -decodeHint (word, count) - = let word' = decode UTF8 word - count' = read $ BS.unpack count - in - (word', count') - --- |Search for documents in many databases at once. -metaSearch :: [Database] -> Condition -> IO [(Database, DocumentID)] -metaSearch dbs cond - = withArrayOfPtrs withDBPtr dbs $ \ dbPtrArray -> - withCondPtr cond $ \ condPtr -> - alloca $ \ retLenPtr -> - do retPtr <- _search_meta dbPtrArray (length dbs) condPtr retLenPtr nullPtr - retLen <- peek retLenPtr - ret <- liftM (decodeMetaSearchRec dbs) $ peekArray retLen retPtr - free retPtr - return ret - --- |Search for documents in many databases at once. The second item of --- the resulting tuple is a map from each search words to the number --- of documents which are matched to the word. -metaSearch' :: [Database] - -> Condition - -> IO ([(Database, DocumentID)], [(String, Int)]) -metaSearch' dbs cond - = do hints <- CM.newMap - withArrayOfPtrs withDBPtr dbs $ \ dbPtrArray -> - withCondPtr cond $ \ condPtr -> - alloca $ \ retLenPtr -> - CM.withMapPtr hints $ \ hintsPtr -> - do retPtr <- _search_meta dbPtrArray (length dbs) condPtr retLenPtr hintsPtr - retLen <- peek retLenPtr - ret <- liftM (decodeMetaSearchRec dbs) $ peekArray retLen retPtr - free retPtr - hints' <- liftM (map decodeHint) (CM.toList hints) - return (ret, hints') - - -decodeMetaSearchRec :: [Database] -> [Int] -> [(Database, DocumentID)] -decodeMetaSearchRec _ [] = [] -decodeMetaSearchRec dbs (dbIdx:docId:xs) = (dbs !! dbIdx, docId) : decodeMetaSearchRec dbs xs - --- |Check if a document matches to every phrases in a condition. --- --- To be honest with you, the author of this binding doesn't really --- know what @est_db_scan_doc()@ does. Its documentation is way too --- ambiguous across the board. Moreover, the names of symbols of the --- HyperEstraier are very badly named. Can you imagine what, say --- @est_db_out_doc()@ does? How about the constant named --- @ESTCONDSURE@? The author got tired of examining the commentless --- source code over and over again to write this binding. Its --- functionality is awesome though... -scanDocument :: Database -> Document -> Condition -> IO Bool -scanDocument db doc cond - = withDBPtr db $ \ dbPtr -> - withDocPtr doc $ \ docPtr -> - withCondPtr cond $ \ condPtr -> - _scan_doc dbPtr docPtr condPtr - >>= return . (/= 0) - --- |Change the size of various caches of a database. Passing negative --- values leaves the old values unchanged. -setCacheSize :: Database -- ^ The database. - -> Int -- ^ Maximum size of the index cache. (default: 64 MiB) - -> Int -- ^ Maximum records of cached attributes. (default: 8192 records) - -> Int -- ^ Maximum number of cached document text. (default: 1024 documents) - -> Int -- ^ Maximum number of the cached search results. (default: 256 records) - -> IO () -setCacheSize db size anum tnum rnum - = withDBPtr db $ \ dbPtr -> - _set_cache_size dbPtr (fromIntegral size) anum tnum rnum diff --git a/Text/HyperEstraier/Document.hs b/Text/HyperEstraier/Document.hs deleted file mode 100644 --- a/Text/HyperEstraier/Document.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# LINE 1 "Text/HyperEstraier/Document.hsc" #-} --- #prune -{-# LINE 2 "Text/HyperEstraier/Document.hsc" #-} - --- |An interface to manipulate documents of the HyperEstraier. - -module Text.HyperEstraier.Document - ( -- * Types - Document - , DocumentID - - , ESTDOC -- private - , wrapDoc -- private - , withDocPtr -- private - - -- * Creating and parsing document - , newDocument - , parseDraft - - -- * Setting contents and attributes of document - , addText - , addHiddenText - , setAttribute - , setURI - , setKeywords - , setScore - - -- * Getting contents and attributes of document - , getId - , getAttrNames - , getAttribute - , getText - , getURI - , getKeywords - , getScore - - -- * Dumping document - , dumpDraft - - -- * Making snippet of document - , makeSnippet - ) - where - -import qualified Data.ByteString.Char8 as B8 -import Data.Encoding -import Data.Encoding.UTF8 -import Data.Maybe -import qualified Database.QDBM.Cabin.List as CL -import qualified Database.QDBM.Cabin.Map as CM -import Foreign.C.String -import Foreign.ForeignPtr -import Foreign.Ptr -import Text.HyperEstraier.Utils -import Network.URI - --- |'Document' is an opaque object representing a document of --- HyperEstraier. -newtype Document = Document (ForeignPtr ESTDOC) -data ESTDOC - --- |'DocumentID' is just an alias to 'Prelude.Int'. It represents a --- document ID. -type DocumentID = Int - - -foreign import ccall unsafe "estraier.h est_doc_new" - _new :: IO (Ptr ESTDOC) - -foreign import ccall unsafe "estraier.h est_doc_new_from_draft" - _new_from_draft :: CString -> IO (Ptr ESTDOC) - -foreign import ccall unsafe "estraier.h &est_doc_delete" - _delete :: FunPtr (Ptr ESTDOC -> IO ()) - -foreign import ccall unsafe "estraier.h est_doc_add_attr" - _add_attr :: Ptr ESTDOC -> CString -> CString -> IO () - -foreign import ccall unsafe "estraier.h est_doc_add_text" - _add_text :: Ptr ESTDOC -> CString -> IO () - -foreign import ccall unsafe "estraier.h est_doc_add_hidden_text" - _add_hidden_text :: Ptr ESTDOC -> CString -> IO () - -foreign import ccall unsafe "estraier.h est_doc_set_keywords" - _set_keywords :: Ptr ESTDOC -> Ptr CM.CBMAP -> IO () - -foreign import ccall unsafe "estraier.h est_doc_set_score" - _set_score :: Ptr ESTDOC -> Int -> IO () - -foreign import ccall unsafe "estraier.h est_doc_id" - _id :: Ptr ESTDOC -> IO Int - -foreign import ccall unsafe "estraier.h est_doc_attr_names" - _attr_names :: Ptr ESTDOC -> IO (Ptr CL.CBLIST) - -foreign import ccall unsafe "estraier.h est_doc_attr" - _attr :: Ptr ESTDOC -> CString -> IO CString - -foreign import ccall unsafe "estraier.h est_doc_cat_texts" - _cat_texts :: Ptr ESTDOC -> IO CString - -foreign import ccall unsafe "estraier.h est_doc_keywords" - _keywords :: Ptr ESTDOC -> IO (Ptr CM.CBMAP) - -foreign import ccall unsafe "estraier.h est_doc_score" - _score :: Ptr ESTDOC -> IO Int - -foreign import ccall unsafe "estraier.h est_doc_dump_draft" - _dump_draft :: Ptr ESTDOC -> IO CString - -foreign import ccall unsafe "estraier.h est_doc_make_snippet" - _make_snippet :: Ptr ESTDOC -> Ptr CL.CBLIST -> Int -> Int -> Int -> IO CString - - -wrapDoc :: Ptr ESTDOC -> IO Document -wrapDoc docPtr = newForeignPtr _delete docPtr >>= return . Document - - -withDocPtr :: Document -> (Ptr ESTDOC -> IO a) -> IO a -withDocPtr (Document doc) = withForeignPtr doc - --- |'newDocument' creates an empty document. -newDocument :: IO Document -newDocument = _new >>= wrapDoc - --- |'parseDraft' parses a document in the \"draft\" format. -parseDraft :: String -> IO Document -parseDraft draft - = withUTF8CString draft $ \ draftPtr -> - _new_from_draft draftPtr >>= wrapDoc - --- |Set an attribute value of a document. -setAttribute :: Document -- ^ The document. - -> String -- ^ An attribute name. - -> Maybe String -- ^ An attribute value. If this is - -- 'Prelude.Nothing', the attribute - -- will be deleted. - -> IO () -setAttribute doc name value - = withDocPtr doc $ \ docPtr -> - withUTF8CString name $ \ namePtr -> - withUTF8CString' value $ \ valuePtr -> - _add_attr docPtr namePtr valuePtr - --- |Add a block of text to a document. -addText :: Document -> String -> IO () -addText doc text - = withDocPtr doc $ \ docPtr -> - withUTF8CString text $ \ textPtr -> - _add_text docPtr textPtr - --- |Add a block of hidden text to a document. -addHiddenText :: Document -> String -> IO () -addHiddenText doc text - = withDocPtr doc $ \ docPtr -> - withUTF8CString text $ \ textPtr -> - _add_hidden_text docPtr textPtr - --- |Set an URI of a document. This is a special case of --- 'setAttribute'. -setURI :: Document -> Maybe URI -> IO () -setURI doc uri = setAttribute doc "@uri" (fmap uri2str uri) - where - uri2str uri = uriToString id uri "" - --- |Set keywords of a document. -setKeywords :: Document -- ^ The document. - -> [(String, Integer)] -- ^ A list of @(keyword, score)@. - -> IO () -setKeywords doc keywords - = withDocPtr doc $ \ docPtr -> - withKeywordMapPtr $ \ mapPtr -> - _set_keywords docPtr mapPtr - where - withKeywordMapPtr :: (Ptr CM.CBMAP -> IO a) -> IO a - withKeywordMapPtr f = do m <- CM.fromList $ map encodeKeyword keywords - CM.withMapPtr m f - - encodeKeyword (word, score) = (encode UTF8 word, B8.pack $ show score) - --- |Set an alternative score of a document. -setScore :: Document -> Maybe Int -> IO () -setScore doc score - = withDocPtr doc $ \ docPtr -> - _set_score docPtr (fromMaybe (-1) score) - --- |Get the ID of document. -getId :: Document -> IO DocumentID -getId doc - = withDocPtr doc $ \ docPtr -> - _id docPtr - --- |Get a list of all attribute names in a document. -getAttrNames :: Document -> IO [String] -getAttrNames doc - = withDocPtr doc $ \ docPtr -> - _attr_names docPtr - >>= CL.wrapList - >>= CL.toList - >>= return . map (decode UTF8) - --- |Get an attribute value of a document. -getAttribute :: Document -> String -> IO (Maybe String) -getAttribute doc name - = withDocPtr doc $ \ docPtr -> - withUTF8CString name $ \ namePtr -> - do valuePtr <- _attr docPtr namePtr - if valuePtr == nullPtr then - return Nothing - else - copyUTF8CString valuePtr >>= return . Just - --- |Get the text in a document. -getText :: Document -> IO String -getText doc - = withDocPtr doc $ \ docPtr -> - _cat_texts docPtr - >>= packMallocUTF8CString - --- |Get the URI of a document. -getURI :: Document -> IO (Maybe URI) -getURI doc = getAttribute doc "@uri" >>= return . fmap parse - where - parse :: String -> URI - parse = fromJust . parseURIReference - --- |Get the keywords of a document. -getKeywords :: Document -> IO [(String, Integer)] -getKeywords doc - = withDocPtr doc $ \ docPtr -> - _keywords docPtr - >>= CM.unsafePeekMap - >>= CM.toList - -- ここまで正格。次の行は遲延される。 - >>= return . map decodeKeyword - where - decodeKeyword (word, score) = (decode UTF8 word, read $ B8.unpack score) - --- |Get an alternative score of a document. -getScore :: Document -> IO (Maybe Int) -getScore doc - = withDocPtr doc $ \ docPtr -> - _score docPtr >>= \ n -> - case n of - -1 -> return Nothing - _ -> return (Just n) - --- |Dump a document in the \"draft\" format. -dumpDraft :: Document -> IO String -dumpDraft doc - = withDocPtr doc $ \ docPtr -> - _dump_draft docPtr >>= packMallocUTF8CString - --- |Make a snippet from a document. -makeSnippet - :: Document -- ^ The document. - -> [String] -- ^ Words to be highlighted. - -> Int -- ^ Maximum width of the whole result. - -> Int -- ^ Width of the heading text to be shown. - -> Int -- ^ Width of the text surrounding each highlighted words. - -> IO [Either String (String, String)] -- ^ A list of either - -- @('Prelude.Left' - -- non-highlighted text)@ - -- or @('Prelude.Right' - -- (highlighted word, its - -- normalized form))@. -makeSnippet doc words wwidth hwidth awidth - = do wordsList <- CL.fromList $ map (encode UTF8) words - withDocPtr doc $ \ docPtr -> - CL.withListPtr wordsList $ \ wordsPtr -> - _make_snippet docPtr wordsPtr wwidth hwidth awidth - >>= packMallocUTF8CString - >>= return . parseSnippet - where - parseSnippet :: String -> [Either String (String, String)] - parseSnippet = map parseLine . lines - - parseLine :: String -> Either String (String, String) - parseLine line = case break (== '\t') line of - (x, "" ) -> Left x - (x, '\t':y) -> Right (x, y) diff --git a/Text/HyperEstraier/Utils.hs b/Text/HyperEstraier/Utils.hs deleted file mode 100644 --- a/Text/HyperEstraier/Utils.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_GHC -optc-D__GLASGOW_HASKELL__=606 #-} -{-# LINE 1 "Text/HyperEstraier/Utils.hsc" #-} -module Text.HyperEstraier.Utils -{-# LINE 2 "Text/HyperEstraier/Utils.hsc" #-} - ( withUTF8CString - , withUTF8CString' - , packMallocUTF8CString - , copyUTF8CString - - , marshalOpts - - , withArrayOfPtrs - ) - where - -import Data.Bits -import qualified Data.ByteString as BS -import Data.Encoding -import Data.Encoding.UTF8 -import Foreign.C.String -import Foreign.Marshal.Array -import Foreign.Ptr - - --- Yet another withUTF8CString. Hope GHC officially supports this! -withUTF8CString :: String -> (CString -> IO a) -> IO a -withUTF8CString = BS.useAsCString . encode UTF8 - - -withUTF8CString' :: Maybe String -> (CString -> IO a) -> IO a -withUTF8CString' (Just str) f = BS.useAsCString (encode UTF8 str) f -withUTF8CString' Nothing f = f nullPtr - - -packMallocUTF8CString :: CString -> IO String -packMallocUTF8CString = return . decode UTF8 . BS.packMallocCString - - -copyUTF8CString :: CString -> IO String -copyUTF8CString cstr = BS.copyCString cstr >>= return . decode UTF8 - --- (.) の型は (b -> c) -> (a -> b) -> a -> c である。(.) は同じ arity --- の函數を繋げる。map は二引數函數なので、それと繋げる方も二引數にしな --- ければならない。所で foldl (.|.) 0 の型は Bits a => [a] -> a で一引 --- 數である。これを (foldl (.|.) 0 .) にすると、その型は Bits b => (a --- -> [b]) -> a -> b になり、單純に Bits a のリストを取ってゐた函數が --- 「何かの値を取って Bits b のリストを返す函數」と「その何かの値」を取 --- る函數に變化する。それを (.) の左邊に置くと、((foldl (.|.) 0 .) .) --- の型は Bits c => (a -> b -> [c]) -> a -> b -> c になる。この函數に --- map を適用すると、map の型は (a -> b) -> [a] -> [b] なので、結果は --- Bits b => (a -> b) -> [a] -> b になる。 --- --- point-free って難しいね。 -marshalOpts :: Bits b => (a -> b) -> [a] -> b -marshalOpts = (foldl (.|.) 0 .) . map - - -withArrayOfPtrs :: (a -> (Ptr b -> IO c) -> IO c) - -> [a] - -> (Ptr (Ptr b) -> IO c) - -> IO c -withArrayOfPtrs withXPtr xs f - = withXPtrList xs [] $ \ xPtrs -> - withArray xPtrs f - where - -- withXPtrList :: [a] -> [Ptr b] -> ([Ptr b] -> IO c) -> IO c - withXPtrList [] acc f = f acc - withXPtrList (x:xs) acc f = withXPtr x $ \ xPtr -> - withXPtrList xs (acc ++ [xPtr]) f