diff --git a/Database/QDBM/Cabin/List.hsc b/Database/QDBM/Cabin/List.hsc --- a/Database/QDBM/Cabin/List.hsc +++ b/Database/QDBM/Cabin/List.hsc @@ -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 diff --git a/Database/QDBM/Cabin/Map.hsc b/Database/QDBM/Cabin/Map.hsc --- a/Database/QDBM/Cabin/Map.hsc +++ b/Database/QDBM/Cabin/Map.hsc @@ -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 () diff --git a/HsHyperEstraier.cabal b/HsHyperEstraier.cabal --- a/HsHyperEstraier.cabal +++ b/HsHyperEstraier.cabal @@ -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 Maintainer: PHO 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 - diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -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. diff --git a/Text/HyperEstraier.hs b/Text/HyperEstraier.hs --- a/Text/HyperEstraier.hs +++ b/Text/HyperEstraier.hs @@ -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. -- --- +-- module Text.HyperEstraier ( module Text.HyperEstraier.Document diff --git a/Text/HyperEstraier/Condition.hsc b/Text/HyperEstraier/Condition.hsc --- a/Text/HyperEstraier/Condition.hsc +++ b/Text/HyperEstraier/Condition.hsc @@ -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 diff --git a/Text/HyperEstraier/Database.hsc b/Text/HyperEstraier/Database.hsc --- a/Text/HyperEstraier/Database.hsc +++ b/Text/HyperEstraier/Database.hsc @@ -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) diff --git a/Text/HyperEstraier/Document.hsc b/Text/HyperEstraier/Document.hsc --- a/Text/HyperEstraier/Document.hsc +++ b/Text/HyperEstraier/Document.hsc @@ -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) diff --git a/Text/HyperEstraier/Utils.hsc b/Text/HyperEstraier/Utils.hsc --- a/Text/HyperEstraier/Utils.hsc +++ b/Text/HyperEstraier/Utils.hsc @@ -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 diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -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" diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,7 +1,5 @@ -GHCFLAGS = -fglasgow-exts - build: - ghc $(GHCFLAGS) --make HelloWorld + ghc --make HelloWorld run: build ./HelloWorld