HsHyperEstraier 0.3.2.1 → 0.4
raw patch · 11 files changed
+551/−500 lines, 11 filesdep +base-unicode-symbolsdep +textdep −utf8-stringdep ~basedep ~network
Dependencies added: base-unicode-symbols, text
Dependencies removed: utf8-string
Dependency ranges changed: base, network
Files
- Database/QDBM/Cabin/List.hsc +37/−32
- Database/QDBM/Cabin/Map.hsc +61/−57
- HsHyperEstraier.cabal +8/−9
- NEWS +6/−0
- Text/HyperEstraier.hs +1/−1
- Text/HyperEstraier/Condition.hsc +57/−50
- Text/HyperEstraier/Database.hsc +198/−187
- Text/HyperEstraier/Document.hsc +120/−108
- Text/HyperEstraier/Utils.hsc +38/−35
- examples/HelloWorld.hs +24/−18
- examples/Makefile +1/−3
Database/QDBM/Cabin/List.hsc view
@@ -1,3 +1,8 @@+{-# LANGUAGE+ EmptyDataDecls+ , ForeignFunctionInterface+ , UnicodeSyntax+ #-} module Database.QDBM.Cabin.List ( List , CBLIST@@ -14,16 +19,16 @@ , fromList ) where- import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString)-import Data.Maybe-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Alloc-import Prelude hiding (length, (!!))+import Data.Maybe+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Prelude hiding (length, (!!))+import Prelude.Unicode infixl 9 !!@@ -34,67 +39,67 @@ foreign import ccall unsafe "cabin.h cblistopen"- _open :: IO (Ptr CBLIST)+ _open ∷ IO (Ptr CBLIST) foreign import ccall unsafe "cabin.h &cblistclose"- _close :: FunPtr (Ptr CBLIST -> IO ())+ _close ∷ FunPtr (Ptr CBLIST → IO ()) foreign import ccall unsafe "cabin.h cblistnum"- _num :: Ptr CBLIST -> IO CInt+ _num ∷ Ptr CBLIST → IO CInt foreign import ccall unsafe "cabin.h cblistval"- _val :: Ptr CBLIST -> CInt -> Ptr CInt -> IO (Ptr CChar)+ _val ∷ Ptr CBLIST → CInt → Ptr CInt → IO (Ptr CChar) foreign import ccall unsafe "cabin.h cblistpush"- _push :: Ptr CBLIST -> Ptr CChar -> CInt -> IO ()+ _push ∷ Ptr CBLIST → Ptr CChar → CInt → IO () -wrapList :: Ptr CBLIST -> IO List+wrapList ∷ Ptr CBLIST → IO List wrapList listPtr = fmap List (newForeignPtr _close listPtr) -withListPtr :: List -> (Ptr CBLIST -> IO a) -> IO a+withListPtr ∷ List → (Ptr CBLIST → IO a) → IO a withListPtr (List list) = withForeignPtr list -newList :: IO List+newList ∷ IO List newList = _open >>= wrapList -push :: List -> Strict.ByteString -> IO ()+push ∷ List → Strict.ByteString → IO () push list value- = withListPtr list $ \ listPtr ->- C8.useAsCStringLen value $ \ (valuePtr, valueLen) ->+ = withListPtr list $ \ listPtr →+ C8.useAsCStringLen value $ \ (valuePtr, valueLen) → _push listPtr valuePtr (fromIntegral valueLen) -length :: List -> IO Int+length ∷ List → IO Int length list- = withListPtr list $ \ listPtr ->+ = withListPtr list $ \ listPtr → fmap fromIntegral (_num listPtr) -(!!) :: List -> Int -> IO (Maybe Strict.ByteString)+(!!) ∷ List → Int → IO (Maybe Strict.ByteString) list !! index- = withListPtr list $ \ listPtr ->- alloca $ \ valLenPtr ->- do valPtr <- _val listPtr (fromIntegral index) valLenPtr- if valPtr == nullPtr then+ = withListPtr list $ \ listPtr →+ alloca $ \ valLenPtr →+ do valPtr ← _val listPtr (fromIntegral index) valLenPtr+ if valPtr ≡ nullPtr then return Nothing else- do valLen <- peek valLenPtr- value <- C8.packCStringLen (valPtr, fromIntegral valLen)+ do valLen ← peek valLenPtr+ value ← C8.packCStringLen (valPtr, fromIntegral valLen) return $ Just value -toList :: List -> IO [Strict.ByteString]+toList ∷ List → IO [Strict.ByteString] toList list- = do len <- length list+ = do len ← length list fmap catMaybes (mapM (list !!) [0..len]) -fromList :: [Strict.ByteString] -> IO List+fromList ∷ [Strict.ByteString] → IO List fromList values- = do list <- newList+ = do list ← newList mapM_ (push list) values return list
Database/QDBM/Cabin/Map.hsc view
@@ -1,3 +1,8 @@+{-# LANGUAGE+ EmptyDataDecls+ , ForeignFunctionInterface+ , UnicodeSyntax+ #-} module Database.QDBM.Cabin.Map ( Map , CBMAP@@ -14,124 +19,123 @@ , fromList ) where--+import Control.Monad.Unicode import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString)-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Alloc-+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Prelude.Unicode newtype Map = Map (ForeignPtr CBMAP) data CBMAP foreign import ccall unsafe "cabin.h cbmapopen"- _open :: IO (Ptr CBMAP)+ _open ∷ IO (Ptr CBMAP) foreign import ccall unsafe "cabin.h &cbmapclose"- _close :: FunPtr (Ptr CBMAP -> IO ())+ _close ∷ FunPtr (Ptr CBMAP → IO ()) foreign import ccall unsafe "cabin.h cbmapput"- _put :: Ptr CBMAP -> Ptr CChar -> CInt -> Ptr CChar -> CInt -> CInt -> IO CInt+ _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)+ _get ∷ Ptr CBMAP → Ptr CChar → CInt → Ptr CInt → IO (Ptr CChar) foreign import ccall unsafe "cabin.h cbmapiterinit"- _iterinit :: Ptr CBMAP -> IO ()+ _iterinit ∷ Ptr CBMAP → IO () foreign import ccall unsafe "cabin.h cbmapiternext"- _iternext :: Ptr CBMAP -> Ptr CInt -> IO (Ptr CChar)+ _iternext ∷ Ptr CBMAP → Ptr CInt → IO (Ptr CChar) foreign import ccall unsafe "cabin.h cbmapiterval"- _iterval :: Ptr CChar -> Ptr CInt -> IO (Ptr CChar)+ _iterval ∷ Ptr CChar → Ptr CInt → IO (Ptr CChar) -wrapMap :: Ptr CBMAP -> IO Map-wrapMap = fmap Map . newForeignPtr _close+wrapMap ∷ Ptr CBMAP → IO Map+wrapMap = fmap Map ∘ newForeignPtr _close -unsafePeekMap :: Ptr CBMAP -> IO Map-unsafePeekMap = fmap Map . newForeignPtr_+unsafePeekMap ∷ Ptr CBMAP → IO Map+unsafePeekMap = fmap Map ∘ newForeignPtr_ -withMapPtr :: Map -> (Ptr CBMAP -> IO a) -> IO a+withMapPtr ∷ Map → (Ptr CBMAP → IO a) → IO a withMapPtr (Map m) = withForeignPtr m -newMap :: IO Map-newMap = _open >>= wrapMap+newMap ∷ IO Map+newMap = _open ≫= wrapMap -put :: Map -> Strict.ByteString -> Strict.ByteString -> Bool -> IO Bool+put ∷ Map → Strict.ByteString → Strict.ByteString → Bool → IO Bool put m key value overwrite- = withMapPtr m $ \ mapPtr ->- C8.useAsCStringLen key $ \ (keyPtr , keyLen ) ->- C8.useAsCStringLen value $ \ (valuePtr, valueLen) ->+ = withMapPtr m $ \ mapPtr →+ C8.useAsCStringLen key $ \ (keyPtr , keyLen ) →+ C8.useAsCStringLen value $ \ (valuePtr, valueLen) → fmap (/= 0) (_put mapPtr keyPtr (fromIntegral keyLen ) valuePtr (fromIntegral valueLen) (fromIntegral $ fromEnum overwrite)) -get :: Map -> Strict.ByteString -> IO (Maybe Strict.ByteString)+get ∷ Map → Strict.ByteString → IO (Maybe Strict.ByteString) get m key- = withMapPtr m $ \ mapPtr ->- C8.useAsCStringLen key $ \ (keyPtr, keyLen) ->- alloca $ \ valLenPtr ->- do valPtr <- _get mapPtr keyPtr (fromIntegral keyLen) valLenPtr- if valPtr == nullPtr then+ = withMapPtr m $ \ mapPtr →+ C8.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 <- C8.packCStringLen (valPtr, fromIntegral valLen)+ do valLen ← peek valLenPtr+ value ← C8.packCStringLen (valPtr, fromIntegral valLen) return $ Just value -initIterator :: Map -> IO ()+initIterator ∷ Map → IO () initIterator m = withMapPtr m _iterinit -iterateNext :: Map -> IO (Maybe (Strict.ByteString, Strict.ByteString))+iterateNext ∷ Map → IO (Maybe (Strict.ByteString, Strict.ByteString)) iterateNext m- = withMapPtr m $ \ mapPtr ->- alloca $ \ keyLenPtr ->- alloca $ \ valLenPtr ->- do keyPtr <- _iternext mapPtr keyLenPtr- if keyPtr == nullPtr then+ = withMapPtr m $ \ mapPtr →+ alloca $ \ keyLenPtr →+ alloca $ \ valLenPtr →+ do keyPtr ← _iternext mapPtr keyLenPtr+ if keyPtr ≡ nullPtr then return Nothing else- do keyLen <- peek keyLenPtr- key <- C8.packCStringLen (keyPtr, fromIntegral keyLen)- valPtr <- _iterval keyPtr valLenPtr- valLen <- peek valLenPtr- value <- C8.packCStringLen (valPtr, fromIntegral valLen)+ do keyLen ← peek keyLenPtr+ key ← C8.packCStringLen (keyPtr, fromIntegral keyLen)+ valPtr ← _iterval keyPtr valLenPtr+ valLen ← peek valLenPtr+ value ← C8.packCStringLen (valPtr, fromIntegral valLen) return $ Just (key, value) -- Internal state of the iterator is stored in the Map itself. That's -- not thread-safe. So we can't iterate it lazily.-toList :: Map -> IO [(Strict.ByteString, Strict.ByteString)]-toList m = initIterator m >> loop+toList ∷ Map → IO [(Strict.ByteString, Strict.ByteString)]+toList m = initIterator m≫ loop where- loop :: IO [(Strict.ByteString, Strict.ByteString)]- loop = do next <- iterateNext m+ loop ∷ IO [(Strict.ByteString, Strict.ByteString)]+ loop = do next ← iterateNext m case next of- Nothing -> return []- Just pair -> do -- We want to do unsafeInterleaveIO+ Nothing → return []+ Just pair → do -- We want to do unsafeInterleaveIO -- here, but we can't.- rest <- loop+ rest ← loop return $ pair : rest -fromList :: [(Strict.ByteString, Strict.ByteString)] -> IO Map+fromList ∷ [(Strict.ByteString, Strict.ByteString)] → IO Map fromList pairs- = do m <- newMap+ = do m ← newMap mapM_ (putPair m) pairs return m where- putPair :: Map -> (Strict.ByteString, Strict.ByteString) -> IO ()- putPair m (key, value) = put m key value True >> return ()+ putPair ∷ Map → (Strict.ByteString, Strict.ByteString) → IO ()+ putPair m (key, value) = put m key value True ≫ return ()
HsHyperEstraier.cabal view
@@ -5,15 +5,16 @@ Haskell. HyperEstraier is an embeddable full text search engine which is supposed to be independent to any particular natural languages.-Version: 0.3.2.1+Version: 0.4 License: PublicDomain License-File: COPYING Author: PHO <pho at cielonegro dot org> Maintainer: PHO <pho at cielonegro dot org> Stability: experimental Homepage: http://cielonegro.org/HsHyperEstraier.html+Bug-Reports: http://static.cielonegro.org/ditz/HsHyperEstraier/ Category: Text-Tested-With: GHC == 6.12.3+Tested-With: GHC == 7.0.3 Cabal-Version: >= 1.6 Build-Type: Simple Extra-Source-Files:@@ -27,10 +28,11 @@ Library Build-Depends:- base == 4.2.*,- bytestring == 0.9.*,- network == 2.2.*,- utf8-string == 0.3.*+ base == 4.3.*,+ base-unicode-symbols == 0.2.*,+ bytestring == 0.9.*,+ network == 2.3.*,+ text == 0.11.* PkgConfig-Depends: hyperestraier >= 1.4.9, qdbm >= 1.8.74@@ -43,8 +45,5 @@ Database.QDBM.Cabin.List Database.QDBM.Cabin.Map Text.HyperEstraier.Utils- Extensions:- DeriveDataTypeable, EmptyDataDecls, ForeignFunctionInterface GHC-Options: -Wall-
NEWS view
@@ -1,3 +1,9 @@+Changes from 0.3.2.1 to 0.4+---------------------------+* HsHyperEstraier now uses Bryan O'Sullivan's brilliant Text data type+ instead of plain old String. Many functions changed their signatures+ due to this change.+ Changes from 0.3.2 to 0.3.2.1 ----------------------------- * Fix breakage on 64-bit environments; reported by Mats Rauhala.
Text/HyperEstraier.hs view
@@ -6,7 +6,7 @@ -- Before reading this documentation, you should see the manual of the -- HyperEstraier to understand how it works and what terms it uses. ----- <http://hyperestraier.sourceforge.net/>+-- <http://fallabs.com/hyperestraier/index.html> module Text.HyperEstraier ( module Text.HyperEstraier.Document
Text/HyperEstraier/Condition.hsc view
@@ -1,3 +1,9 @@+{-# LANGUAGE+ EmptyDataDecls+ , ForeignFunctionInterface+ , UnicodeSyntax+ #-}+ #include "estraier.h" {-# OPTIONS_HADDOCK prune #-}@@ -30,13 +36,15 @@ ) where -import Control.Exception-import Data.Bits-import Foreign.C.String-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import Text.HyperEstraier.Utils+import Control.Exception+import Data.Bits+import qualified Data.Text as T+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Prelude.Unicode+import Text.HyperEstraier.Utils -- |'Condition' is an opaque object representing a search condition. newtype Condition = Condition (ForeignPtr ESTCOND)@@ -72,7 +80,7 @@ -- details. deriving (Eq, Show) -marshalCondOption :: CondOption -> CInt+marshalCondOption ∷ CondOption → CInt marshalCondOption (Speed Slow ) = #const ESTCONDSURE marshalCondOption (Speed Normal ) = #const ESTCONDUSUAL marshalCondOption (Speed Fast ) = #const ESTCONDFAST@@ -102,81 +110,80 @@ deriving (Eq, Show) -marshalEclipse :: Eclipse -> CDouble+marshalEclipse ∷ Eclipse → CDouble marshalEclipse (Threshold thr) = assertThreshold (realToFrac thr) marshalEclipse (ThresholdWithURL thr) = assertThreshold (realToFrac thr) + #const ESTECLSIMURL marshalEclipse SameServer = #const ESTECLSERV marshalEclipse SameDirectory = #const ESTECLDIR marshalEclipse SameFile = #const ESTECLFILE -assertThreshold :: (Fractional a, Ord a) => a -> a+assertThreshold ∷ (Fractional a, Ord a) ⇒ a → a assertThreshold thr = assert (thr >= 0.0 && thr <= 1.0) thr foreign import ccall unsafe "estraier.h est_cond_new"- _new :: IO (Ptr ESTCOND)+ _new ∷ IO (Ptr ESTCOND) foreign import ccall unsafe "estraier.h &est_cond_delete"- _delete :: FunPtr (Ptr ESTCOND -> IO ())+ _delete ∷ FunPtr (Ptr ESTCOND → IO ()) foreign import ccall unsafe "estraier.h est_cond_set_phrase"- _set_phrase :: Ptr ESTCOND -> CString -> IO ()+ _set_phrase ∷ Ptr ESTCOND → CString → IO () foreign import ccall unsafe "estraier.h est_cond_add_attr"- _add_attr :: Ptr ESTCOND -> CString -> IO ()+ _add_attr ∷ Ptr ESTCOND → CString → IO () foreign import ccall unsafe "estraier.h est_cond_set_order"- _set_order :: Ptr ESTCOND -> CString -> IO ()+ _set_order ∷ Ptr ESTCOND → CString → IO () foreign import ccall unsafe "estraier.h est_cond_set_max"- _set_max :: Ptr ESTCOND -> CInt -> IO ()+ _set_max ∷ Ptr ESTCOND → CInt → IO () foreign import ccall unsafe "estraier.h est_cond_set_skip"- _set_skip :: Ptr ESTCOND -> CInt -> IO ()+ _set_skip ∷ Ptr ESTCOND → CInt → IO () foreign import ccall unsafe "estraier.h est_cond_set_options"- _set_options :: Ptr ESTCOND -> CInt -> IO ()+ _set_options ∷ Ptr ESTCOND → CInt → IO () foreign import ccall unsafe "estraier.h est_cond_set_auxiliary"- _set_auxiliary :: Ptr ESTCOND -> CInt -> IO ()+ _set_auxiliary ∷ Ptr ESTCOND → CInt → IO () foreign import ccall unsafe "estraier.h est_cond_set_eclipse"- _set_eclipse :: Ptr ESTCOND -> CDouble -> IO ()+ _set_eclipse ∷ Ptr ESTCOND → CDouble → IO () foreign import ccall unsafe "estraier.h est_cond_set_distinct"- _set_distinct :: Ptr ESTCOND -> CString -> IO ()+ _set_distinct ∷ Ptr ESTCOND → CString → IO () foreign import ccall unsafe "estraier.h est_cond_set_mask"- _set_mask :: Ptr ESTCOND -> CInt -> IO ()+ _set_mask ∷ Ptr ESTCOND → CInt → IO () -wrapCond :: Ptr ESTCOND -> IO Condition-wrapCond = fmap Condition . newForeignPtr _delete-+wrapCond ∷ Ptr ESTCOND → IO Condition+wrapCond = fmap Condition ∘ newForeignPtr _delete -withCondPtr :: Condition -> (Ptr ESTCOND -> IO a) -> IO a+withCondPtr ∷ Condition → (Ptr ESTCOND → IO a) → IO a withCondPtr (Condition cond) = withForeignPtr cond -- |'newCondition' creates an empty search condition.-newCondition :: IO 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 ∷ Condition → T.Text → IO () setPhrase cond phrase- = withCondPtr cond $ \ condPtr ->+ = withCondPtr cond $ \ condPtr → withUTF8CString phrase $ _set_phrase condPtr -- |@'addAttrCond' cond expr@ appends an attribute search condition to -- @cond@. See the user's guide for explanation about the attribute -- search condition.-addAttrCond :: Condition -> String -> IO ()+addAttrCond ∷ Condition → T.Text → IO () addAttrCond cond attr- = withCondPtr cond $ \ condPtr ->+ = withCondPtr cond $ \ condPtr → withUTF8CString attr $ _add_attr condPtr @@ -184,27 +191,27 @@ -- @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 ∷ Condition → T.Text → IO () setOrder cond order- = withCondPtr cond $ \ condPtr ->+ = withCondPtr cond $ \ condPtr → withUTF8CString order $ _set_order condPtr -- |@'setMax' cond n@ specifies the maximum number of results. By -- default, the number of results is unlimited.-setMax :: Condition -> Int -> IO ()+setMax ∷ Condition → Int → IO () setMax cond- = withCondPtr cond . flip _set_max . fromIntegral+ = withCondPtr cond ∘ flip _set_max ∘ fromIntegral -- |@'setSkip' cond n@ specifies how many documents should be skipped -- from the beginning of result.-setSkip :: Condition -> Int -> IO ()+setSkip ∷ Condition → Int → IO () setSkip cond- = withCondPtr cond . flip _set_skip . fromIntegral+ = withCondPtr cond ∘ flip _set_skip ∘ fromIntegral -- |@'setOptions' cond opts@ specifies options to the search -- condition.-setOptions :: Condition -> [CondOption] -> IO ()+setOptions ∷ Condition → [CondOption] → IO () setOptions cond = withCondPtr cond . flip _set_options .@@ -212,21 +219,21 @@ -- |@'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 ∷ Condition → Int → IO () setAuxiliary cond- = withCondPtr cond . flip _set_auxiliary . fromIntegral+ = withCondPtr cond ∘ flip _set_auxiliary ∘ fromIntegral -- |@'setEclipse' cond ecl@ specifies how to hide documents from the -- search result by their similarity.-setEclipse :: Condition -> Eclipse -> IO ()+setEclipse ∷ Condition → Eclipse → IO () setEclipse cond- = withCondPtr cond . flip _set_eclipse . marshalEclipse+ = withCondPtr cond ∘ flip _set_eclipse ∘ marshalEclipse -- |@'setDistinct' cond attr@ specifies an attribute which must be -- unique to the search result.-setDistinct :: Condition -> String -> IO ()+setDistinct ∷ Condition → T.Text → IO () setDistinct cond attr- = withCondPtr cond $ \ condPtr ->+ = withCondPtr cond $ \ condPtr → withUTF8CString attr $ _set_distinct condPtr @@ -234,9 +241,9 @@ -- '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 ->+-- > 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@@ -245,11 +252,11 @@ -- > result <- metaSearch [db1, db2, db3] -- > print result ---setMetaSearchMask :: Condition -> [Int] -> IO ()+setMetaSearchMask ∷ Condition → [Int] → IO () setMetaSearchMask cond- = withCondPtr cond . flip _set_max . fromIntegral . calculateMask+ = withCondPtr cond ∘ flip _set_max ∘ fromIntegral ∘ calculateMask where- calculateMask :: [Int] -> Int+ calculateMask ∷ [Int] → Int calculateMask [] = 0 calculateMask (y:ys) = assert (y >= 0 && y <= 28) $ (1 `shiftL` y) .|. calculateMask ys
Text/HyperEstraier/Database.hsc view
@@ -1,3 +1,11 @@+{-# LANGUAGE+ DeriveDataTypeable+ , EmptyDataDecls+ , ForeignFunctionInterface+ , OverloadedStrings+ , UnicodeSyntax+ #-}+ #include "estraier.h" -- |An interface to functions to manipulate databases.@@ -59,27 +67,29 @@ , scanDocument ) where--import Codec.Binary.UTF8.String-import Control.Exception-import Control.Monad-import Data.Bits-import qualified Data.ByteString as Strict (ByteString)+import Control.Exception+import Control.Monad+import Control.Monad.Unicode+import Data.Bits+import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Char8 as C8 hiding (ByteString)-import Data.IORef-import Data.Maybe-import Data.Typeable+import Data.IORef+import Data.Maybe+import qualified Data.Text as T+import Data.Text.Encoding+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+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+import Prelude.Unicode -- |'EstError' represents an error occured on various operations. data EstError@@ -95,7 +105,7 @@ instance Exception EstError -unmarshalError :: CInt -> EstError+unmarshalError ∷ CInt → EstError unmarshalError (#const ESTEINVAL ) = InvalidArgument unmarshalError (#const ESTEACCES ) = AccessForbidden unmarshalError (#const ESTELOCK ) = LockFailure@@ -187,39 +197,39 @@ deriving (Eq, Show) -marshalOpenMode :: OpenMode -> CInt+marshalOpenMode ∷ OpenMode → CInt marshalOpenMode (Reader opts) = (#const ESTDBREADER) .|. marshalOpts marshalReaderOption opts marshalOpenMode (Writer opts) = (#const ESTDBWRITER) .|. marshalOpts marshalWriterOption opts -marshalReaderOption :: ReaderOption -> CInt+marshalReaderOption ∷ ReaderOption → CInt marshalReaderOption (ReadLock mode) = marshalLockingMode mode -marshalWriterOption :: WriterOption -> CInt+marshalWriterOption ∷ WriterOption → CInt marshalWriterOption (Create opts) = (#const ESTDBCREAT) .|. marshalOpts marshalCreateOption opts marshalWriterOption (Truncate opts) = (#const ESTDBTRUNC) .|. marshalOpts marshalCreateOption opts marshalWriterOption (WriteLock mode) = marshalLockingMode mode -marshalLockingMode :: LockingMode -> CInt+marshalLockingMode ∷ LockingMode → CInt marshalLockingMode NoLock = #const ESTDBNOLCK marshalLockingMode NonblockingLock = #const ESTDBLCKNB -marshalCreateOption :: CreateOption -> CInt+marshalCreateOption ∷ CreateOption → CInt marshalCreateOption (Analysis opt ) = marshalAnalysisOption opt marshalCreateOption (Index tuning) = marshalIndexTuning tuning marshalCreateOption (Score opts ) = marshalOpts marshalScoreOption opts -marshalAnalysisOption :: AnalysisOption -> CInt+marshalAnalysisOption ∷ AnalysisOption → CInt marshalAnalysisOption PerfectNGram = #const ESTDBPERFNG marshalAnalysisOption CharCategory = #const ESTDBCHRCAT -marshalIndexTuning :: IndexTuning -> CInt+marshalIndexTuning ∷ IndexTuning → CInt marshalIndexTuning Small = #const ESTDBSMALL marshalIndexTuning Large = #const ESTDBLARGE marshalIndexTuning Huge = #const ESTDBHUGE marshalIndexTuning Huge2 = #const ESTDBHUGE2 marshalIndexTuning Huge3 = #const ESTDBHUGE3 -marshalScoreOption :: ScoreOption -> CInt+marshalScoreOption ∷ ScoreOption → CInt marshalScoreOption Nullified = #const ESTDBSCVOID marshalScoreOption StoredAsInt = #const ESTDBSCINT marshalScoreOption OnlyToBeStored = #const ESTDBSCASIS@@ -237,7 +247,7 @@ deriving (Eq, Show) -marshalAttrIndexType :: AttrIndexType -> CInt+marshalAttrIndexType ∷ AttrIndexType → CInt marshalAttrIndexType SeqIndex = #const ESTIDXATTRSEQ marshalAttrIndexType StrIndex = #const ESTIDXATTRSTR marshalAttrIndexType NumIndex = #const ESTIDXATTRNUM@@ -251,7 +261,7 @@ deriving (Eq, Show) -marshalOptimizeOption :: OptimizeOption -> CInt+marshalOptimizeOption ∷ OptimizeOption → CInt marshalOptimizeOption NoPurge = #const ESTOPTNOPURGE marshalOptimizeOption NoDBOptimize = #const ESTOPTNODBOPT @@ -263,7 +273,7 @@ deriving (Eq, Show) -marshalRemoveOption :: RemoveOption -> CInt+marshalRemoveOption ∷ RemoveOption → CInt marshalRemoveOption CleaningRemove = #const ESTODCLEAN -- |'PutOption' is an option for the 'putDocument' action.@@ -276,7 +286,7 @@ deriving (Eq, Show) -marshalPutOption :: PutOption -> CInt+marshalPutOption ∷ PutOption → CInt marshalPutOption CleaningPut = #const ESTPDCLEAN marshalPutOption WeightStatically = #const ESTPDWEIGHT @@ -287,7 +297,7 @@ | NoKeywords -- ^ Don't retrieve the keywords of the document. deriving (Eq, Show) -marshalGetOption :: GetOption -> CInt+marshalGetOption ∷ GetOption → CInt marshalGetOption NoAttributes = #const ESTGDNOATTR marshalGetOption NoText = #const ESTGDNOTEXT marshalGetOption NoKeywords = #const ESTGDNOKWD@@ -299,82 +309,82 @@ foreign import ccall unsafe "estmtdb.h est_mtdb_open"- _open :: CString -> CInt -> Ptr CInt -> IO (Ptr ESTMTDB)+ _open ∷ CString → CInt → Ptr CInt → IO (Ptr ESTMTDB) foreign import ccall unsafe "estmtdb.h est_mtdb_close"- _close :: Ptr ESTMTDB -> Ptr CInt -> IO CInt+ _close ∷ Ptr ESTMTDB → Ptr CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_error"- _error :: Ptr ESTMTDB -> IO CInt+ _error ∷ Ptr ESTMTDB → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_fatal"- _fatal :: Ptr ESTMTDB -> IO CInt+ _fatal ∷ Ptr ESTMTDB → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_add_attr_index"- _add_attr_index :: Ptr ESTMTDB -> CString -> CInt -> IO CInt+ _add_attr_index ∷ Ptr ESTMTDB → CString → CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_flush"- _flush :: Ptr ESTMTDB -> CInt -> IO CInt+ _flush ∷ Ptr ESTMTDB → CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_sync"- _sync :: Ptr ESTMTDB -> IO CInt+ _sync ∷ Ptr ESTMTDB → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_optimize"- _optimize :: Ptr ESTMTDB -> CInt -> IO CInt+ _optimize ∷ Ptr ESTMTDB → CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_merge"- _merge :: Ptr ESTMTDB -> CString -> CInt -> IO CInt+ _merge ∷ Ptr ESTMTDB → CString → CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_put_doc"- _put_doc :: Ptr ESTMTDB -> Ptr ESTDOC -> CInt -> IO CInt+ _put_doc ∷ Ptr ESTMTDB → Ptr ESTDOC → CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_out_doc"- _out_doc :: Ptr ESTMTDB -> CInt -> CInt -> IO CInt+ _out_doc ∷ Ptr ESTMTDB → CInt → CInt → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_edit_doc"- _edit_doc :: Ptr ESTMTDB -> Ptr ESTDOC -> IO CInt+ _edit_doc ∷ Ptr ESTMTDB → Ptr ESTDOC → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_get_doc"- _get_doc :: Ptr ESTMTDB -> CInt -> CInt -> IO (Ptr ESTDOC)+ _get_doc ∷ Ptr ESTMTDB → CInt → CInt → IO (Ptr ESTDOC) foreign import ccall unsafe "estmtdb.h est_mtdb_get_doc_attr"- _get_doc_attr :: Ptr ESTMTDB -> CInt -> CString -> IO CString+ _get_doc_attr ∷ Ptr ESTMTDB → CInt → CString → IO CString foreign import ccall unsafe "estmtdb.h est_mtdb_uri_to_id"- _uri_to_id :: Ptr ESTMTDB -> CString -> IO CInt+ _uri_to_id ∷ Ptr ESTMTDB → CString → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_name"- _name :: Ptr ESTMTDB -> IO CString+ _name ∷ Ptr ESTMTDB → IO CString foreign import ccall unsafe "estmtdb.h est_mtdb_doc_num"- _doc_num :: Ptr ESTMTDB -> IO CInt+ _doc_num ∷ Ptr ESTMTDB → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_word_num"- _word_num :: Ptr ESTMTDB -> IO CInt+ _word_num ∷ Ptr ESTMTDB → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_size"- _size :: Ptr ESTMTDB -> IO CDouble+ _size ∷ Ptr ESTMTDB → IO CDouble foreign import ccall unsafe "estmtdb.h est_mtdb_search"- _search :: Ptr ESTMTDB -> Ptr ESTCOND -> Ptr CInt -> Ptr CM.CBMAP -> IO (Ptr CInt)+ _search ∷ Ptr ESTMTDB → Ptr ESTCOND → Ptr CInt → Ptr CM.CBMAP → IO (Ptr CInt) foreign import ccall unsafe "estmtdb.h est_mtdb_search_meta"- _search_meta :: Ptr (Ptr ESTMTDB) -> CInt -> Ptr ESTCOND -> Ptr CInt -> Ptr CM.CBMAP -> IO (Ptr CInt)+ _search_meta ∷ Ptr (Ptr ESTMTDB) → CInt → Ptr ESTCOND → Ptr CInt → Ptr CM.CBMAP → IO (Ptr CInt) foreign import ccall unsafe "estmtdb.h est_mtdb_scan_doc"- _scan_doc :: Ptr ESTMTDB -> Ptr ESTDOC -> Ptr ESTCOND -> IO CInt+ _scan_doc ∷ Ptr ESTMTDB → Ptr ESTDOC → Ptr ESTCOND → IO CInt foreign import ccall unsafe "estmtdb.h est_mtdb_set_cache_size"- _set_cache_size :: Ptr ESTMTDB -> CSize -> CInt -> CInt -> CInt -> IO ()+ _set_cache_size ∷ Ptr ESTMTDB → CSize → CInt → CInt → CInt → IO () -wrapDB :: Ptr ESTMTDB -> IO Database+wrapDB ∷ Ptr ESTMTDB → IO Database wrapDB dbPtr = fmap Database (newIORef dbPtr) -withDBPtr :: Database -> (Ptr ESTMTDB -> IO a) -> IO a+withDBPtr ∷ Database → (Ptr ESTMTDB → IO a) → IO a withDBPtr (Database ref) f- = do dbPtr <- readIORef ref+ = do dbPtr ← readIORef ref if dbPtr == nullPtr then fail "The HyperEstraier DB has already been closed." else@@ -384,14 +394,14 @@ -- 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 ∷ 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+ openDB' ∷ IO Database+ openDB' = do ret ← openDatabase fpath opts case ret of- Left err -> throwIO err- Right db -> return db+ Left err → throwIO err+ Right db → return db -- |@'openDatabase' fpath mode@ opens a database at @fpath@. If it -- succeeds it returns @'Prelude.Right' 'Database'@, otherwise it@@ -402,254 +412,255 @@ -- 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 ∷ FilePath → OpenMode → IO (Either EstError Database) openDatabase fpath opts- = withUTF8CString fpath $ \ fpathPtr ->- alloca $ \ errPtr ->- do dbPtr <- _open fpathPtr (marshalOpenMode opts) errPtr+ = withUTF8CString path' $ \ fpathPtr →+ alloca $ \ errPtr →+ do dbPtr ← _open fpathPtr (marshalOpenMode opts) errPtr if dbPtr == nullPtr then- fmap (Left . unmarshalError) (peek errPtr)+ fmap (Left ∘ unmarshalError) (peek errPtr) else fmap Right (wrapDB dbPtr)+ where+ path' = T.pack fpath -- |@'closeDatabase' db@ closes the database @db@. If the @db@ has -- already been closed, this operation causes nothing.-closeDatabase :: Database -> IO ()+closeDatabase ∷ Database → IO () closeDatabase (Database ref)- = do dbPtr <- readIORef ref+ = do dbPtr ← readIORef ref when (dbPtr /= nullPtr) (close' dbPtr) where- close' :: Ptr ESTMTDB -> IO ()+ close' ∷ Ptr ESTMTDB → IO () close' dbPtr- = alloca $ \ errPtr ->- do ret <- _close dbPtr errPtr+ = alloca $ \ errPtr →+ do ret ← _close dbPtr errPtr case ret of- 0 -> peek errPtr >>= throwIO . unmarshalError- _ -> writeIORef ref nullPtr+ 0 → peek errPtr ≫= throwIO ∘ unmarshalError+ _ → writeIORef ref nullPtr -throwLastError :: Database -> IO a+throwLastError ∷ Database → IO a throwLastError db- = withDBPtr db $ \ dbPtr ->- _error dbPtr >>= throwIO . unmarshalError+ = withDBPtr db $ \ dbPtr →+ _error dbPtr ≫= throwIO ∘ unmarshalError -throwLastErrorIf :: Database -> Bool -> IO ()+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 ∷ Database → IO Bool hasFatalError db- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → fmap (/= 0) (_fatal dbPtr) -- |@'addAttrIndex' db attr idxType@ creates an index of type -- @idxType@ for attribute @attr@ into the database @db@.-addAttrIndex :: Database -> String -> AttrIndexType -> IO ()+addAttrIndex ∷ Database → T.Text → AttrIndexType → IO () addAttrIndex db attr idxType- = withDBPtr db $ \ dbPtr ->- withUTF8CString attr $ \ attrPtr ->+ = withDBPtr db $ \ dbPtr →+ withUTF8CString attr $ \ attrPtr → _add_attr_index dbPtr attrPtr (marshalAttrIndexType idxType)- >>= throwLastErrorIf db . (== 0)+ ≫= 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 ∷ Database → Int → IO () flushDatabase db maxWords- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → _flush dbPtr (fromIntegral maxWords)- >>= throwLastErrorIf db . (== 0)+ ≫= throwLastErrorIf db ∘ (== 0) -- |Synchronize a database to the disk.-syncDatabase :: Database -> IO ()+syncDatabase ∷ Database → IO () syncDatabase db- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → _sync dbPtr- >>= throwLastErrorIf db . (== 0)+ ≫= throwLastErrorIf db ∘ (== 0) -- |Optimize a database.-optimizeDatabase :: Database -> [OptimizeOption] -> IO ()+optimizeDatabase ∷ Database → [OptimizeOption] → IO () optimizeDatabase db opts- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → _optimize dbPtr (marshalOpts marshalOptimizeOption opts)- >>= throwLastErrorIf db . (== 0)+ ≫= 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 ∷ Database → FilePath → [RemoveOption] → IO () mergeDatabase db fpath opts- = withDBPtr db $ \ dbPtr ->- withUTF8CString fpath $ \ fpathPtr ->+ = withDBPtr db $ \ dbPtr →+ withUTF8CString path' $ \ fpathPtr → _merge dbPtr fpathPtr (marshalOpts marshalRemoveOption opts)- >>= throwLastErrorIf db . (== 0)+ ≫= throwLastErrorIf db ∘ (== 0)+ where+ path' = T.pack fpath -- |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 ∷ Database → Document → [PutOption] → IO () putDocument db doc opts- = withDBPtr db $ \ dbPtr ->- withDocPtr doc $ \ docPtr ->+ = withDBPtr db $ \ dbPtr →+ withDocPtr doc $ \ docPtr → _put_doc dbPtr docPtr (marshalOpts marshalPutOption opts)- >>= throwLastErrorIf db . (== 0)+ ≫= throwLastErrorIf db ∘ (== 0) -- |Remove a document from a database.-removeDocument :: Database -> DocumentID -> [RemoveOption] -> IO ()+removeDocument ∷ Database → DocumentID → [RemoveOption] → IO () removeDocument db docId opts- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → _out_doc dbPtr (fromIntegral docId) (marshalOpts marshalRemoveOption opts)- >>= throwLastErrorIf db . (== 0)+ ≫= 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 ∷ Database → Document → IO () updateDocAttrs db doc- = withDBPtr db $ \ dbPtr ->- withDocPtr doc $ \ docPtr ->+ = withDBPtr db $ \ dbPtr →+ withDocPtr doc $ \ docPtr → _edit_doc dbPtr docPtr- >>= throwLastErrorIf db . (== 0)+ ≫= throwLastErrorIf db ∘ (== 0) -- |Find a document in a database by an ID.-getDocument :: Database -> DocumentID -> [GetOption] -> IO Document+getDocument ∷ Database → DocumentID → [GetOption] → IO Document getDocument db docId opts- = withDBPtr db $ \ dbPtr ->- do docPtr <- _get_doc dbPtr (fromIntegral docId)+ = withDBPtr db $ \ dbPtr →+ do docPtr ← _get_doc dbPtr (fromIntegral 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 ∷ Database → DocumentID → T.Text → IO (Maybe T.Text) getDocAttr db docId name- = withDBPtr db $ \ dbPtr ->- withUTF8CString name $ \ namePtr ->- do valuePtr <- _get_doc_attr dbPtr (fromIntegral docId) namePtr+ = withDBPtr db $ \ dbPtr →+ withUTF8CString name $ \ namePtr →+ do valuePtr ← _get_doc_attr dbPtr (fromIntegral docId) namePtr if valuePtr == nullPtr then return Nothing else fmap Just (packMallocUTF8CString valuePtr) -- |Get the URI of a document in a database.-getDocURI :: Database -> DocumentID -> IO URI+getDocURI ∷ Database → DocumentID → IO URI getDocURI db docId- = fmap (fromJust . parseURI . fromJust) (getDocAttr db docId "@uri")+ = fmap (fromJust ∘ parseURI ∘ T.unpack ∘ fromJust) (getDocAttr db docId "@uri") -- |Find a document in a database by an URI and return its ID.-getDocIdByURI :: Database -> URI -> IO (Maybe DocumentID)+getDocIdByURI ∷ Database → URI → IO (Maybe DocumentID) getDocIdByURI db uri- = withDBPtr db $ \ dbPtr ->- withUTF8CString (uriToString id uri "") $ \ uriPtr ->- do ret <- liftM fromIntegral $ _uri_to_id dbPtr uriPtr+ = withDBPtr db $ \ dbPtr →+ withUTF8CString (T.pack $ uriToString id uri "") $ \ uriPtr →+ do ret ← liftM fromIntegral $ _uri_to_id dbPtr uriPtr case ret of- -1 -> return Nothing- _ -> return (Just ret)+ -1 → return Nothing+ _ → return (Just ret) -- |Get the name of a database.-getDatabaseName :: Database -> IO String+getDatabaseName ∷ Database → IO T.Text getDatabaseName db- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → _name dbPtr - >>= peekUTF8CString+ ≫= peekUTF8CString -- |Get the number of documents in a database.-getNumOfDocs :: Database -> IO Int+getNumOfDocs ∷ Database → IO Int getNumOfDocs- = liftM fromIntegral . flip withDBPtr _doc_num+ = liftM fromIntegral ∘ flip withDBPtr _doc_num -- |Get the number of words in a database.-getNumOfWords :: Database -> IO Int+getNumOfWords ∷ Database → IO Int getNumOfWords- = liftM fromIntegral . flip withDBPtr _word_num+ = liftM fromIntegral ∘ flip withDBPtr _word_num -- |Get the size of a database.-getDatabaseSize :: Database -> IO Integer+getDatabaseSize ∷ Database → IO Integer getDatabaseSize db- = withDBPtr db $ \ dbPtr ->+ = withDBPtr db $ \ dbPtr → -- Why est_db_size() returns double? Why not size_t or long long -- int? Crazy. fmap floor (_size dbPtr) -- |Search for documents in a database by a condition.-searchDatabase :: Database -> Condition -> IO [DocumentID]+searchDatabase ∷ Database → Condition → IO [DocumentID] searchDatabase db cond- = withDBPtr db $ \ dbPtr ->- withCondPtr cond $ \ condPtr ->- alloca $ \ retLenPtr ->- do retPtr <- _search dbPtr condPtr retLenPtr nullPtr- retLen <- liftM fromIntegral $ peek retLenPtr- ret <- liftM (map fromIntegral) $ peekArray retLen retPtr+ = withDBPtr db $ \ dbPtr →+ withCondPtr cond $ \ condPtr →+ alloca $ \ retLenPtr →+ do retPtr ← _search dbPtr condPtr retLenPtr nullPtr+ retLen ← liftM fromIntegral $ peek retLenPtr+ ret ← liftM (map fromIntegral) $ 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' ∷ Database → Condition → IO ([DocumentID], [(T.Text, 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 <- liftM fromIntegral $ peek retLenPtr- ret <- liftM (map fromIntegral) $ peekArray retLen retPtr+ = do hints ← CM.newMap+ withDBPtr db $ \ dbPtr →+ withCondPtr cond $ \ condPtr →+ alloca $ \ retLenPtr →+ CM.withMapPtr hints $ \ hintsPtr →+ do retPtr ← _search dbPtr condPtr retLenPtr hintsPtr+ retLen ← liftM fromIntegral $ peek retLenPtr+ ret ← liftM (map fromIntegral) $ peekArray retLen retPtr free retPtr- hints' <- liftM (map decodeHint) (CM.toList hints)+ hints' ← liftM (map decodeHint) (CM.toList hints) return (ret, hints') -decodeHint :: (Strict.ByteString, Strict.ByteString) -> (String, Int)+decodeHint ∷ (B.ByteString, B.ByteString) → (T.Text, Int) decodeHint (word, count)- = let word' = decodeString $ C8.unpack word- count' = read $ C8.unpack count- in- (word', count')+ = (decodeUtf8 word, read $ C8.unpack count) -- |Search for documents in many databases at once.-metaSearch :: [Database] -> Condition -> IO [(Database, DocumentID)]+metaSearch ∷ [Database] → Condition → IO [(Database, DocumentID)] metaSearch dbs cond- = withArrayOfPtrs withDBPtr dbs $ \ dbPtrArray ->- withCondPtr cond $ \ condPtr ->- alloca $ \ retLenPtr ->- do retPtr <- _search_meta dbPtrArray (fromIntegral $ length dbs) condPtr retLenPtr nullPtr- retLen <- liftM fromIntegral $ peek retLenPtr- ret <- liftM (decodeMetaSearchRec dbs) $ peekArray retLen retPtr+ = withArrayOfPtrs withDBPtr dbs $ \ dbPtrArray →+ withCondPtr cond $ \ condPtr →+ alloca $ \ retLenPtr →+ do retPtr ← _search_meta dbPtrArray (fromIntegral $ length dbs) condPtr retLenPtr nullPtr+ retLen ← liftM fromIntegral $ 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' ∷ [Database]+ → Condition+ → IO ([(Database, DocumentID)], [(T.Text, 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 (fromIntegral $ length dbs) condPtr retLenPtr hintsPtr- retLen <- liftM fromIntegral $ peek retLenPtr- ret <- liftM (decodeMetaSearchRec dbs) $ peekArray retLen retPtr+ = do hints ← CM.newMap+ withArrayOfPtrs withDBPtr dbs $ \ dbPtrArray →+ withCondPtr cond $ \ condPtr →+ alloca $ \ retLenPtr →+ CM.withMapPtr hints $ \ hintsPtr →+ do retPtr ← _search_meta dbPtrArray (fromIntegral $ length dbs) condPtr retLenPtr hintsPtr+ retLen ← liftM fromIntegral $ peek retLenPtr+ ret ← liftM (decodeMetaSearchRec dbs) $ peekArray retLen retPtr free retPtr- hints' <- liftM (map decodeHint) (CM.toList hints)+ hints' ← liftM (map decodeHint) (CM.toList hints) return (ret, hints') -decodeMetaSearchRec :: [Database] -> [CInt] -> [(Database, DocumentID)]+decodeMetaSearchRec ∷ [Database] → [CInt] → [(Database, DocumentID)] decodeMetaSearchRec _ [] = [] decodeMetaSearchRec dbs (dbIdx:docId:xs) = (dbs !! fromIntegral dbIdx, fromIntegral docId) : decodeMetaSearchRec dbs xs@@ -665,23 +676,23 @@ -- @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 ∷ Database → Document → Condition → IO Bool scanDocument db doc cond- = withDBPtr db $ \ dbPtr ->- withDocPtr doc $ \ docPtr ->- withCondPtr cond $ \ condPtr ->+ = withDBPtr db $ \ dbPtr →+ withDocPtr doc $ \ docPtr →+ withCondPtr cond $ \ condPtr → fmap (/= 0) (_scan_doc dbPtr docPtr condPtr) -- |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 ∷ 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 ->+ = withDBPtr db $ \ dbPtr → _set_cache_size dbPtr (fromIntegral size) (fromIntegral anum) (fromIntegral tnum)
Text/HyperEstraier/Document.hsc view
@@ -1,3 +1,10 @@+{-# LANGUAGE+ EmptyDataDecls+ , ForeignFunctionInterface+ , OverloadedStrings+ , UnicodeSyntax+ #-}+ {-# OPTIONS_HADDOCK prune #-} -- |An interface to manipulate documents of the HyperEstraier.@@ -39,20 +46,22 @@ , makeSnippet ) where--import Codec.Binary.UTF8.String-import Control.Monad-import qualified Data.ByteString.Char8 as C8-import Data.Maybe+import Control.Monad+import Control.Monad.Unicode+import Data.Maybe+import qualified Data.ByteString.Char8 as C8+import qualified Data.Text as T+import Data.Text.Encoding import qualified Database.QDBM.Cabin.List as CL import qualified Database.QDBM.Cabin.Map as CM-import Foreign.C.String-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import Text.HyperEstraier.Utils-import Network.URI-import Prelude hiding (words)+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Text.HyperEstraier.Utils+import Network.URI+import Prelude hiding (words)+import Prelude.Unicode -- |'Document' is an opaque object representing a document of -- HyperEstraier.@@ -65,144 +74,145 @@ foreign import ccall unsafe "estraier.h est_doc_new"- _new :: IO (Ptr ESTDOC)+ _new ∷ IO (Ptr ESTDOC) foreign import ccall unsafe "estraier.h est_doc_new_from_draft"- _new_from_draft :: CString -> IO (Ptr ESTDOC)+ _new_from_draft ∷ CString → IO (Ptr ESTDOC) foreign import ccall unsafe "estraier.h &est_doc_delete"- _delete :: FunPtr (Ptr ESTDOC -> IO ())+ _delete ∷ FunPtr (Ptr ESTDOC → IO ()) foreign import ccall unsafe "estraier.h est_doc_add_attr"- _add_attr :: Ptr ESTDOC -> CString -> CString -> IO ()+ _add_attr ∷ Ptr ESTDOC → CString → CString → IO () foreign import ccall unsafe "estraier.h est_doc_add_text"- _add_text :: Ptr ESTDOC -> CString -> IO ()+ _add_text ∷ Ptr ESTDOC → CString → IO () foreign import ccall unsafe "estraier.h est_doc_add_hidden_text"- _add_hidden_text :: Ptr ESTDOC -> CString -> IO ()+ _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 ()+ _set_keywords ∷ Ptr ESTDOC → Ptr CM.CBMAP → IO () foreign import ccall unsafe "estraier.h est_doc_set_score"- _set_score :: Ptr ESTDOC -> CInt -> IO ()+ _set_score ∷ Ptr ESTDOC → CInt → IO () foreign import ccall unsafe "estraier.h est_doc_id"- _id :: Ptr ESTDOC -> IO CInt+ _id ∷ Ptr ESTDOC → IO CInt foreign import ccall unsafe "estraier.h est_doc_attr_names"- _attr_names :: Ptr ESTDOC -> IO (Ptr CL.CBLIST)+ _attr_names ∷ Ptr ESTDOC → IO (Ptr CL.CBLIST) foreign import ccall unsafe "estraier.h est_doc_attr"- _attr :: Ptr ESTDOC -> CString -> IO CString+ _attr ∷ Ptr ESTDOC → CString → IO CString foreign import ccall unsafe "estraier.h est_doc_cat_texts"- _cat_texts :: Ptr ESTDOC -> IO CString+ _cat_texts ∷ Ptr ESTDOC → IO CString foreign import ccall unsafe "estraier.h est_doc_keywords"- _keywords :: Ptr ESTDOC -> IO (Ptr CM.CBMAP)+ _keywords ∷ Ptr ESTDOC → IO (Ptr CM.CBMAP) foreign import ccall unsafe "estraier.h est_doc_score"- _score :: Ptr ESTDOC -> IO CInt+ _score ∷ Ptr ESTDOC → IO CInt foreign import ccall unsafe "estraier.h est_doc_dump_draft"- _dump_draft :: Ptr ESTDOC -> IO CString+ _dump_draft ∷ Ptr ESTDOC → IO CString foreign import ccall unsafe "estraier.h est_doc_make_snippet"- _make_snippet :: Ptr ESTDOC -> Ptr CL.CBLIST -> CInt -> CInt -> CInt -> IO CString+ _make_snippet ∷ Ptr ESTDOC → Ptr CL.CBLIST → CInt → CInt → CInt → IO CString -wrapDoc :: Ptr ESTDOC -> IO Document-wrapDoc = fmap Document . newForeignPtr _delete+wrapDoc ∷ Ptr ESTDOC → IO Document+wrapDoc = fmap Document ∘ newForeignPtr _delete -withDocPtr :: Document -> (Ptr ESTDOC -> IO a) -> IO a+withDocPtr ∷ Document → (Ptr ESTDOC → IO a) → IO a withDocPtr (Document doc) = withForeignPtr doc -- |'newDocument' creates an empty document.-newDocument :: IO Document-newDocument = _new >>= wrapDoc+newDocument ∷ IO Document+newDocument = _new ≫= wrapDoc -- |'parseDraft' parses a document in the \"draft\" format.-parseDraft :: String -> IO Document+parseDraft ∷ T.Text → IO Document parseDraft draft- = withUTF8CString draft $ \ draftPtr ->- _new_from_draft draftPtr >>= wrapDoc+ = 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 ∷ Document -- ^ The document.+ → T.Text -- ^ An attribute name.+ → Maybe T.Text -- ^ An attribute value. If this is+ -- 'Prelude.Nothing', the attribute will+ -- be deleted.+ → IO () setAttribute doc name value- = withDocPtr doc $ \ docPtr ->- withUTF8CString name $ \ namePtr ->+ = withDocPtr doc $ \ docPtr →+ withUTF8CString name $ \ namePtr → withUTF8CString' value $ _add_attr docPtr namePtr -- |Add a block of text to a document.-addText :: Document -> String -> IO ()+addText ∷ Document → T.Text → IO () addText doc text- = withDocPtr doc $ \ docPtr ->+ = withDocPtr doc $ \ docPtr → withUTF8CString text $ _add_text docPtr -- |Add a block of hidden text to a document.-addHiddenText :: Document -> String -> IO ()+addHiddenText ∷ Document → T.Text → IO () addHiddenText doc text- = withDocPtr doc $ \ docPtr ->+ = withDocPtr doc $ \ docPtr → withUTF8CString text $ _add_hidden_text docPtr -- |Set an URI of a document. This is a special case of -- 'setAttribute'.-setURI :: Document -> Maybe URI -> IO ()+setURI ∷ Document → Maybe URI → IO () setURI doc uri = setAttribute doc "@uri" (fmap uri2str uri) where- uri2str = flip (uriToString id) ""+ uri2str = T.pack ∘ flip (uriToString id) "" -- |Set keywords of a document.-setKeywords :: Document -- ^ The document.- -> [(String, Integer)] -- ^ A list of @(keyword, score)@.- -> IO ()+setKeywords ∷ Document -- ^ The document.+ → [(T.Text, Integer)] -- ^ A list of @(keyword, score)@.+ → IO () setKeywords doc keywords- = withDocPtr doc $ \ docPtr ->+ = withDocPtr doc $ \ docPtr → withKeywordMapPtr $ _set_keywords docPtr where- withKeywordMapPtr :: (Ptr CM.CBMAP -> IO a) -> IO a- withKeywordMapPtr f = do m <- CM.fromList $ map encodeKeyword keywords- CM.withMapPtr m f+ withKeywordMapPtr ∷ (Ptr CM.CBMAP → IO a) → IO a+ withKeywordMapPtr f+ = do m <- CM.fromList $ map encodeKeyword keywords+ CM.withMapPtr m f - encodeKeyword (word, score) = (C8.pack $ encodeString word, C8.pack $ show score)+ encodeKeyword (word, score)+ = (encodeUtf8 word, C8.pack $ show score) -- |Set an alternative score of a document.-setScore :: Document -> Maybe Int -> IO ()+setScore ∷ Document → Maybe Int → IO () setScore doc- = withDocPtr doc . flip _set_score . fromIntegral . fromMaybe (-1)+ = withDocPtr doc ∘ flip _set_score ∘ fromIntegral ∘ fromMaybe (-1) -- |Get the ID of document.-getId :: Document -> IO DocumentID-getId- = liftM fromIntegral . flip withDocPtr _id+getId ∷ Document → IO DocumentID+getId = liftM fromIntegral ∘ flip withDocPtr _id -- |Get a list of all attribute names in a document.-getAttrNames :: Document -> IO [String]+getAttrNames ∷ Document → IO [T.Text] getAttrNames doc- = withDocPtr doc $ \ docPtr ->+ = withDocPtr doc $ \ docPtr → _attr_names docPtr- >>= CL.wrapList- >>= CL.toList- >>= return . map (decodeString . C8.unpack)+ ≫= CL.wrapList+ ≫= CL.toList+ ≫= return ∘ map decodeUtf8 -- |Get an attribute value of a document.-getAttribute :: Document -> String -> IO (Maybe String)+getAttribute ∷ Document → T.Text → IO (Maybe T.Text) getAttribute doc name- = withDocPtr doc $ \ docPtr ->- withUTF8CString name $ \ namePtr ->+ = withDocPtr doc $ \ docPtr →+ withUTF8CString name $ \ namePtr → do valuePtr <- _attr docPtr namePtr if valuePtr == nullPtr then return Nothing@@ -210,72 +220,74 @@ fmap Just (peekUTF8CString valuePtr) -- |Get the text in a document.-getText :: Document -> IO String+getText ∷ Document → IO T.Text getText doc- = withDocPtr doc $ \ docPtr ->+ = withDocPtr doc $ \ docPtr → _cat_texts docPtr- >>= packMallocUTF8CString+ ≫= packMallocUTF8CString -- |Get the URI of a document.-getURI :: Document -> IO (Maybe URI)+getURI ∷ Document → IO (Maybe URI) getURI doc = fmap (fmap parse) (getAttribute doc "@uri") where- parse :: String -> URI- parse = fromJust . parseURIReference+ parse ∷ T.Text → URI+ parse = fromJust ∘ parseURI ∘ T.unpack -- |Get the keywords of a document.-getKeywords :: Document -> IO [(String, Integer)]+getKeywords ∷ Document → IO [(T.Text, Integer)] getKeywords doc- = withDocPtr doc $ \ docPtr ->+ = withDocPtr doc $ \ docPtr → _keywords docPtr- >>= CM.unsafePeekMap- >>= CM.toList- >>= return . map decodeKeyword+ ≫= CM.unsafePeekMap+ ≫= CM.toList+ ≫= return ∘ map decodeKeyword where- decodeKeyword (word, score) = (decodeString $ C8.unpack word, read $ C8.unpack score)+ decodeKeyword (word, score)+ = (decodeUtf8 word, read $ C8.unpack score) -- |Get an alternative score of a document.-getScore :: Document -> IO (Maybe Int)+getScore ∷ Document → IO (Maybe Int) getScore doc- = withDocPtr doc $ \ docPtr ->- _score docPtr >>= \ n ->+ = withDocPtr doc $ \ docPtr →+ _score docPtr ≫= \ n → case n of- -1 -> return Nothing- _ -> return $ Just $ fromIntegral n+ -1 → return Nothing+ _ → return $ Just $ fromIntegral n -- |Dump a document in the \"draft\" format.-dumpDraft :: Document -> IO String+dumpDraft ∷ Document → IO T.Text dumpDraft doc- = withDocPtr doc $ \ docPtr ->- _dump_draft docPtr >>= packMallocUTF8CString+ = 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+ ∷ Document -- ^ The document.+ → [T.Text] -- ^ 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 T.Text (T.Text, T.Text)] -- ^ 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 (C8.pack . encodeString) words- withDocPtr doc $ \ docPtr ->- CL.withListPtr wordsList $ \ wordsPtr ->+ = do wordsList <- CL.fromList $ map encodeUtf8 words+ withDocPtr doc $ \ docPtr →+ CL.withListPtr wordsList $ \ wordsPtr → _make_snippet docPtr wordsPtr (fromIntegral wwidth) (fromIntegral hwidth) (fromIntegral awidth)- >>= packMallocUTF8CString- >>= return . parseSnippet+ ≫= packMallocUTF8CString+ ≫= return ∘ parseSnippet where- parseSnippet :: String -> [Either String (String, String)]- parseSnippet = map parseLine . lines+ parseSnippet ∷ T.Text → [Either T.Text (T.Text, T.Text)]+ parseSnippet = map parseLine ∘ T.lines - parseLine :: String -> Either String (String, String)- parseLine line = case break (== '\t') line of- (x, "" ) -> Left x- (x, _:y) -> Right (x, y)+ parseLine ∷ T.Text → Either T.Text (T.Text, T.Text)+ parseLine line+ = case T.break (== '\t') line of+ (x, y) | T.null y → Left x+ | otherwise → Right (x, T.tail y)
Text/HyperEstraier/Utils.hsc view
@@ -1,3 +1,7 @@+{-# LANGUAGE+ ScopedTypeVariables+ , UnicodeSyntax+ #-} module Text.HyperEstraier.Utils ( withUTF8CString , withUTF8CString'@@ -9,48 +13,47 @@ , withArrayOfPtrs ) where--import Codec.Binary.UTF8.String-import Data.Bits-import Foreign.C.String-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import Foreign.Ptr----- Yet another withUTF8CString. Hope GHC officially supports this!-withUTF8CString :: String -> (CString -> IO a) -> IO a-withUTF8CString = withCString . encodeString+import Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.Text as T+import Data.Text.Encoding+import Foreign.C.String+import Foreign.Marshal.Array+import Foreign.Ptr+import Prelude.Unicode +withUTF8CString ∷ T.Text → (CString → IO a) → IO a+{-# INLINE withUTF8CString #-}+withUTF8CString = B.useAsCString ∘ encodeUtf8 -withUTF8CString' :: Maybe String -> (CString -> IO a) -> IO a-withUTF8CString' (Just str) f = withCString (encodeString str) f+withUTF8CString' ∷ Maybe T.Text → (CString → IO a) → IO a+{-# INLINE withUTF8CString' #-}+withUTF8CString' (Just str) f = B.useAsCString (encodeUtf8 str) f withUTF8CString' Nothing f = f nullPtr --packMallocUTF8CString :: CString -> IO String-packMallocUTF8CString cstr- = do str <- return . decodeString =<< peekCString cstr- free cstr- return str---peekUTF8CString :: CString -> IO String-peekUTF8CString = fmap decodeString . peekCString-+packMallocUTF8CString ∷ CString → IO T.Text+{-# INLINE packMallocUTF8CString #-}+packMallocUTF8CString = fmap decodeUtf8 ∘ B.unsafePackMallocCString -marshalOpts :: Bits b => (a -> b) -> [a] -> b-marshalOpts = (foldl (.|.) 0 .) . map+peekUTF8CString ∷ CString → IO T.Text+{-# INLINE peekUTF8CString #-}+peekUTF8CString = fmap decodeUtf8 ∘ B.packCString +marshalOpts ∷ Bits b => (a → b) → [a] → b+{-# INLINE marshalOpts #-}+marshalOpts = (foldl (.|.) 0 .) ∘ map -withArrayOfPtrs :: (a -> (Ptr b -> IO c) -> IO c)- -> [a]- -> (Ptr (Ptr b) -> IO c)- -> IO c+withArrayOfPtrs ∷ ∀a b c.+ (a → (Ptr b → IO c) → IO c)+ → [a]+ → (Ptr (Ptr b) → IO c)+ → IO c+{-# INLINEABLE withArrayOfPtrs #-} withArrayOfPtrs withXPtr xs f = withXPtrList xs [] $ flip withArray f where- -- withXPtrList :: [a] -> [Ptr b] -> ([Ptr b] -> IO c) -> IO c- withXPtrList [] acc g = g acc- withXPtrList (y:ys) acc g = withXPtr y $ \ xPtr ->- withXPtrList ys (acc ++ [xPtr]) g+ withXPtrList ∷ [a] → [Ptr b] → ([Ptr b] → IO c) → IO c+ withXPtrList [] acc g = g (reverse acc)+ withXPtrList (y:ys) acc g = withXPtr y $ \xPtr →+ withXPtrList ys (xPtr:acc) g
examples/HelloWorld.hs view
@@ -1,12 +1,18 @@ {- -*- Coding: utf-8 -*- -}--import Network.URI-import System.Directory-import Text.HyperEstraier-+{-# LANGUAGE+ OverloadedStrings+ , UnicodeSyntax+ #-}+module Main where+import Control.Monad.Unicode+import qualified Data.Text.IO as T+import Network.URI+import System.Directory+import Text.HyperEstraier+import Prelude.Unicode -main = do withDatabase "casket" (Writer [Create []]) $ \ db ->- do doc <- newDocument+main = do withDatabase "casket" (Writer [Create []]) $ \ db →+ do doc ← newDocument let Just uri = parseURI "http://example.net/hello" @@ -14,29 +20,29 @@ addText doc "Hello, world!" putStrLn ">> Registering the following document:"- dumpDraft doc >>= putStr+ dumpDraft doc ≫= T.putStr putDocument db doc [] - docID <- getId doc- putStrLn (">> Done. The document got ID " ++ show docID ++ ".")+ docID ← getId doc+ putStrLn (">> Done. The document got ID " ⧺ show docID ⧺ ".") putStrLn ">> Trying to search for \"World OR dlroW\"..."- cond <- newCondition+ cond ← newCondition setPhrase cond "World OR dlroW"- result <- searchDatabase db cond- putStrLn (">> Found: " ++ show result)+ result ← searchDatabase db cond+ putStrLn (">> Found: " ⧺ show result) putStrLn ">> Trying to search for \"hêllö\"..."- cond' <- newCondition+ cond' ← newCondition setPhrase cond' "hêllö"- result' <- searchDatabase db cond'- putStrLn (">> Found: " ++ show result')+ result' ← searchDatabase db cond'+ putStrLn (">> Found: " ⧺ show result') if null result' then putStrLn ">> Great, hêllö doesn't match to hello." else- putStrLn (">> hêllö matches to hello... This seems to be indeed a desired behavior, " ++- "but this may cause problems on languages where diacritical marks are " +++ putStrLn (">> hêllö matches to hello... This seems to be indeed a desired behavior, " ⧺+ "but this may cause problems on languages where diacritical marks are " ⧺ "significant to distinguish completely different words...") removeDirectoryRecursive "casket"
examples/Makefile view
@@ -1,7 +1,5 @@-GHCFLAGS = -fglasgow-exts- build:- ghc $(GHCFLAGS) --make HelloWorld+ ghc --make HelloWorld run: build ./HelloWorld