HsHyperEstraier 0.2 → 0.2.1
raw patch · 8 files changed
+10/−1606 lines, 8 files
Files
- Database/QDBM/Cabin/List.hs +0/−103
- Database/QDBM/Cabin/Map.hs +0/−144
- HsHyperEstraier.cabal +6/−5
- NEWS +4/−0
- Text/HyperEstraier/Condition.hs +0/−275
- Text/HyperEstraier/Database.hs +0/−727
- Text/HyperEstraier/Document.hs +0/−283
- Text/HyperEstraier/Utils.hs +0/−69
− Database/QDBM/Cabin/List.hs
@@ -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
− Database/QDBM/Cabin/Map.hs
@@ -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 ()
HsHyperEstraier.cabal view
@@ -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 <phonohawk at ps dot sakura dot ne dot jp>-Maintainer: PHO <phonohawk at ps dot sakura dot ne dot jp>+Author: PHO <pho at cielonegro dot org>+Maintainer: PHO <pho at cielonegro dot org> 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
NEWS view
@@ -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
− Text/HyperEstraier/Condition.hs
@@ -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
− Text/HyperEstraier/Database.hs
@@ -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
− Text/HyperEstraier/Document.hs
@@ -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)
− Text/HyperEstraier/Utils.hs
@@ -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