Holumbus-Searchengine (empty) → 1.2.0
raw patch · 50 files changed
+8233/−0 lines, 50 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, bzlib, containers, deepseq, directory, enummapset, filepath, hslogger, hxt, hxt-cache, hxt-curl, hxt-regex-xmlschema, hxt-unicode, mtl, network, parallel, parsec, process, unix
Files
- Holumbus-Searchengine.cabal +97/−0
- LICENSE +21/−0
- README +56/−0
- Setup.lhs +8/−0
- src/Control/Concurrent/MapFold.hs +63/−0
- src/Control/Monad/ReaderStateIO.hs +60/−0
- src/Control/Sequential/MapFoldBinary.hs +127/−0
- src/Holumbus/Crawler.hs +30/−0
- src/Holumbus/Crawler/CacheCore.hs +144/−0
- src/Holumbus/Crawler/Constants.hs +36/−0
- src/Holumbus/Crawler/Core.hs +391/−0
- src/Holumbus/Crawler/Html.hs +195/−0
- src/Holumbus/Crawler/IndexerCore.hs +281/−0
- src/Holumbus/Crawler/Logger.hs +137/−0
- src/Holumbus/Crawler/PdfToText.hs +59/−0
- src/Holumbus/Crawler/RobotTypes.hs +115/−0
- src/Holumbus/Crawler/Robots.hs +205/−0
- src/Holumbus/Crawler/Types.hs +426/−0
- src/Holumbus/Crawler/URIs.hs +91/−0
- src/Holumbus/Crawler/Util.hs +75/−0
- src/Holumbus/Crawler/XmlArrows.hs +20/−0
- src/Holumbus/Data/Crunch.hs +160/−0
- src/Holumbus/Data/PrefixTree.hs +79/−0
- src/Holumbus/Data/PrefixTree/Core.hs +942/−0
- src/Holumbus/Data/PrefixTree/FuzzySearch.hs +101/−0
- src/Holumbus/Data/PrefixTree/PrefixSet.hs +132/−0
- src/Holumbus/Data/PrefixTree/Types.hs +26/−0
- src/Holumbus/Index/Common.hs +308/−0
- src/Holumbus/Index/Common/BasicTypes.hs +46/−0
- src/Holumbus/Index/Common/DiffList.hs +108/−0
- src/Holumbus/Index/Common/DocId.hs +64/−0
- src/Holumbus/Index/Common/DocIdMap.hs +131/−0
- src/Holumbus/Index/Common/Document.hs +61/−0
- src/Holumbus/Index/Common/LoadStore.hs +68/−0
- src/Holumbus/Index/Common/Occurences.hs +141/−0
- src/Holumbus/Index/Common/RawResult.hs +55/−0
- src/Holumbus/Index/CompactDocuments.hs +313/−0
- src/Holumbus/Index/CompactIndex.hs +276/−0
- src/Holumbus/Index/CompactSmallDocuments.hs +198/−0
- src/Holumbus/Index/Compression.hs +68/−0
- src/Holumbus/Index/Inverted/CompressedPrefixMem.hs +464/−0
- src/Holumbus/Index/Inverted/PrefixMem.hs +228/−0
- src/Holumbus/Query/Fuzzy.hs +218/−0
- src/Holumbus/Query/Intermediate.hs +175/−0
- src/Holumbus/Query/Language/Grammar.hs +144/−0
- src/Holumbus/Query/Language/Parser.hs +181/−0
- src/Holumbus/Query/Processor.hs +352/−0
- src/Holumbus/Query/Ranking.hs +129/−0
- src/Holumbus/Query/Result.hs +260/−0
- src/Holumbus/Utility.hs +168/−0
+ Holumbus-Searchengine.cabal view
@@ -0,0 +1,97 @@+name: Holumbus-Searchengine+version: 1.2.0+license: MIT+license-file: LICENSE+author: Sebastian M. Gauck, Timo B. Huebel, Uwe Schmidt+copyright: Copyright (c) 2007 - 2012 Uwe Schmidt, Sebastian M. Gauck and Timo B. Huebel+maintainer: Timo B. Huebel <tbh@holumbus.org>, Uwe Schmidt <uwe@fh-wedel.de>+stability: experimental+category: Text, Data+synopsis: A search and indexing engine.+homepage: http://holumbus.fh-wedel.de+description: The Holumbus-Searchengine library provides a document indexer+ and crawler to build indexes over document collections+ as well as a sophisticated query interface for these indexes.+cabal-version: >=1.6+build-type: Simple+-- tested-with: ghc-7.0.3++extra-source-files:+ README++library+ build-depends: base >= 4 && < 5+ , binary >= 0.5 && < 1+ , bytestring >= 0.9 && < 1+ , bzlib >= 0.4 && < 1+ , containers >= 0.2 && < 1+ , deepseq >= 1.1 && < 2+ , directory >= 1 && < 2+ , enummapset >= 0 && < 1+ , filepath >= 1 && < 2+ , hslogger >= 1 && < 2+ , hxt >= 9.1 && < 10+ , hxt-cache >= 9 && < 10+ , hxt-curl >= 9 && < 10+ , hxt-regex-xmlschema >= 9 && < 10+ , hxt-unicode >= 9 && < 10+ , mtl >= 1.1 && < 3+ , network >= 2.1 && < 3+ , parallel >= 3.1 && < 4+ , parsec >= 2.1 && < 4+ , process >= 1 && < 2+ , unix >= 2.3 && < 3++ exposed-modules:+ Control.Concurrent.MapFold+ Control.Monad.ReaderStateIO+ Control.Sequential.MapFoldBinary+ Holumbus.Crawler.CacheCore+ Holumbus.Crawler.Constants+ Holumbus.Crawler.Core+ Holumbus.Crawler+ Holumbus.Crawler.Html+ Holumbus.Crawler.IndexerCore+ Holumbus.Crawler.Logger+ Holumbus.Crawler.PdfToText+ Holumbus.Crawler.Robots+ Holumbus.Crawler.RobotTypes+ Holumbus.Crawler.Types+ Holumbus.Crawler.URIs+ Holumbus.Crawler.Util+ Holumbus.Crawler.XmlArrows+ Holumbus.Data.Crunch+ Holumbus.Data.PrefixTree.Core+ Holumbus.Data.PrefixTree.FuzzySearch+ Holumbus.Data.PrefixTree+ Holumbus.Data.PrefixTree.PrefixSet+ Holumbus.Data.PrefixTree.Types+ Holumbus.Index.Common+ Holumbus.Index.Common.BasicTypes+ Holumbus.Index.Common.DiffList+ Holumbus.Index.Common.DocId+ Holumbus.Index.Common.DocIdMap+ Holumbus.Index.Common.Document+ Holumbus.Index.Common.LoadStore+ Holumbus.Index.Common.Occurences+ Holumbus.Index.Common.RawResult+ Holumbus.Index.CompactDocuments+ Holumbus.Index.CompactIndex+ Holumbus.Index.CompactSmallDocuments+ Holumbus.Index.Compression+ Holumbus.Index.Inverted.CompressedPrefixMem+ Holumbus.Index.Inverted.PrefixMem+ Holumbus.Query.Fuzzy+ Holumbus.Query.Intermediate+ Holumbus.Query.Language.Grammar+ Holumbus.Query.Language.Parser+ Holumbus.Query.Processor+ Holumbus.Query.Ranking+ Holumbus.Query.Result+ Holumbus.Utility++ hs-source-dirs: src++ ghc-options: -Wall -funbox-strict-fields -fwarn-tabs++ extensions:
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License++Copyright (c) 2007 Sebastian M. Schlatt, Timo B. Hübel++Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"),+to deal in the Software without restriction, including without limitation the+rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE.
+ README view
@@ -0,0 +1,56 @@+This is Holumbus.++Version 0.4++Sebastian M. Schlatt - sms@holumbus.org+Timo B. Hübel - tbh@holumbus.org++http://www.holumbus.org++About+-----++Holumbus is a Haskell library which provides the basic building blocks for+creating powerful indexing and search applications. This includes a framework+for distributed crawling and indexing as well as distributed query processing.++Contents+--------++doc Detailed information about the internals of Holumbus.+examples Some example applications and utilities.+source Source code of the Holumbus core library.+test Several tests for the Holumbus core library.++Requirements+------------++The Holumbus core library requires at least GHC 6.8.2 and the +following packages (available via Hackage):++- binary 0.4.1+- bzlib 0.4.0.1+- HDBC 1.1.4+- HDBC-sqlite3 1.1.4.0+- hxt 7.5+- regex-compat 0.71.0.1+- utf8-string 0.2++Installation+------------++A Cabal file is provided, therefore Holumbus can be installed using+the standard Cabal way:++$ runhaskell Setup.hs configure+$ runhaskell Setup.hs build+$ runhaskell Setup.hs install # with root privileges++Documentation+-------------++Documentation is provided through the examples and extensive Haddock +API documentation available online at http://www.holumbus.org.++Details about the internals of the Holumbus framework are available in+the extensive descriptions of the implementation in the "doc" directory.
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/runhaskell++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ src/Control/Concurrent/MapFold.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++{- |+ Module : Control.Concurrent.MapFold+ Copyright : Copyright (C) 2010 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: none portable++ A map-fold function for performing list folds in parallel.++-}++-- ------------------------------------------------------------++module Control.Concurrent.MapFold+ ( mapFold )+where++import Control.Concurrent+import Control.DeepSeq++-- ------------------------------------------------------------++mapFold :: (NFData b) => Int -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b+mapFold n m f xs@(_:_) = do+ c <- newChan+ p <- newQSem n+ mapFold' p c m f xs+mapFold _ _ _ [] = error "mapFold: empty list of arguments"++mapFold' :: (NFData b) => QSem -> Chan b -> (a -> IO b) -> (b -> b -> IO b) -> [a] -> IO b+mapFold' p c m f xs = do+ mapM_ (forkWorker m) xs+ foldResults (length xs)+ where+ forkWorker m' x = forkIO process+ >> return ()+ where+ process = do+ waitQSem p -- request processor+ res <- m' x -- work+ rnf res `seq` -- force complete elvaluation+ writeChan c res -- deliver result+ signalQSem p -- release processor+++ foldResults n+ | n == 1 = readChan c -- get final result++ | otherwise = do+ r1 <- readChan c -- get 1. arg+ r2 <- readChan c -- get 2. arg+ forkWorker (uncurry f) (r1, r2)+ -- combine args and put result back into chanel+ foldResults (n - 1) -- continue++-- ------------------------------------------------------------+
+ src/Control/Monad/ReaderStateIO.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS -XMultiParamTypeClasses -XFunctionalDependencies -XFlexibleInstances #-}++-- ------------------------------------------------------------++module Control.Monad.ReaderStateIO+ ( module Control.Monad.ReaderStateIO+ )+where++import Control.Monad.Reader+import Control.Monad.State++-- ------------------------------------------------------------++-- |+-- reader state io monad implemented directly without any monad transformers++newtype ReaderStateIO env state res = RSIO ( env -> state -> IO (res, state) )++instance Monad (ReaderStateIO env state) where+ return v+ = RSIO $ \ _e s -> return (v, s)++ RSIO cmd >>= f+ = RSIO $ \ e s -> do+ (r', s') <- cmd e s+ let RSIO cmd2 = f r'+ s' `seq` cmd2 e s'++instance MonadIO (ReaderStateIO env state) where+ liftIO a+ = RSIO $ \ _e s -> do+ r <- a+ return (r, s)++instance MonadState state (ReaderStateIO env state) where+ get+ = RSIO $ \ _e s -> return (s, s)++ put s+ = RSIO $ \ _e _s -> return ((), s)++instance MonadReader env (ReaderStateIO env state) where+ ask+ = RSIO $ \ e s -> return (e, s)++ local f (RSIO cmd)+ = RSIO $ \ e s -> cmd (f e) s++modifyIO :: (state -> IO state) -> ReaderStateIO env state ()+modifyIO f = do+ s0 <- get+ s1 <- liftIO (f s0)+ put s1++runReaderStateIO :: ReaderStateIO env state res -> env -> state -> IO (res, state)+runReaderStateIO (RSIO cmd) e s+ = cmd e s+ +-- ------------------------------------------------------------
+ src/Control/Sequential/MapFoldBinary.hs view
@@ -0,0 +1,127 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++{- |+ Module : Control.Sequential.MapFoldBinary+ Copyright : Copyright (C) 2010 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental++ A map-fold function for interleaved map and fold.+ The elements of a list are processed like in a binary tree.++-}++-- ------------------------------------------------------------++module Control.Sequential.MapFoldBinary+ ( mapFoldBinary+ , mapFoldBinaryM+ )+where++-- ------------------------------------------------------------++-- | Pure version of binary map fold+--+-- @mapFoldBinary id (+) [1..8]@ adds the elements of a list in the following order:+-- @(((1+2)+(3+4))+((5+6)+(7+8)))@++mapFoldBinary :: (a -> b) -> (b -> b -> b) -> [a] -> b+mapFoldBinary m f xs0 = fst $ mapLeft (1::Int) $ map1 xs0+ where+ -- map1 :: [a] -> (b, [a])+ map1 (x:xs) = (m x, xs)+ map1 [] = error "mapFoldBinary with empty list"++ -- mapLeft :: Int -> (b, [a]) -> (b, [a])+ mapLeft n (r1, xs1)+ | null xs1 = (r1, [])+ | null xs2 = (r, [])+ | otherwise = mapLeft (n + 1) (r, xs2)+ where+ (r2, xs2) = mapRight n xs1+ r = f r1 r2++ -- mapRight :: Int -> [a] -> (b, [a])+ mapRight 1 xs = map1 xs+ mapRight n xs+ | null xs1 = (r1, [] )+ | otherwise = (f r1 r2, xs2)+ where+ (r1, xs1) = mapRight (n - 1) xs+ (r2, xs2) = mapRight (n - 1) xs1++-- ------------------------------------------------------------+{-+t1 :: [Int] -> String+t1 = mapFoldBinary show (\ x y -> "(" ++ x ++ "+" ++ y ++ ")")++r1 :: String+r1 = t1 [1..8]+-}+-- ------------------------------------------------------------++-- | Monadic version of a binary map fold+--+-- The elements of a list are mapped and folded in the same way as in the pure version.+-- The map and fold operations are interleaved. In the above example the expressions are evaluated+-- from left to right, folding is performed, as early as possible.+++mapFoldBinaryM :: (Monad m) =>+ (a -> m b) -> (b -> b -> m b) -> [a] -> m b+mapFoldBinaryM m f xs0 = do+ r0 <- map1 xs0+ rn <- mapLeft (1::Int) r0+ return (fst rn)+ where+ -- map1 :: [a] -> m (b, [a])+ map1 (x:xs) = do+ r1 <- m x+ return (r1, xs)+ map1 [] = error "mapFoldBinary with empty list"++ -- mapLeft :: Int -> (b, [a]) -> m (b, [a])+ mapLeft n r@(r1, xs1)+ | null xs1 = return r+ | otherwise = do+ (r2, xs2) <- mapRight n xs1+ res <- f r1 r2+ ( if null xs2+ then return+ else mapLeft (n + 1) ) (res, xs2)++ -- mapRight :: Int -> [a] -> m (b, [a])+ mapRight 1 xs = map1 xs+ mapRight n xs = do+ r@(r1, xs1) <- mapRight (n - 1) xs+ if null xs1+ then return r+ else do+ (r2, xs2) <- mapRight (n - 1) xs1+ res <- f r1 r2+ return (res, xs2)++-- ------------------------------------------------------------+{-+t1m :: [Int] -> IO String+t1m = mapFoldBinaryM+ ( \ x -> ( do+ print x+ return (show x)+ )+ )+ ( \ x y -> ( do+ putStrLn $ "(" ++ x ++ "+" ++ y ++ ")"+ return $ "(" ++ x ++ "+" ++ y ++ ")"+ )+ )++r1m :: IO String+r1m = t1m [1..8]+-}+-- ------------------------------------------------------------
+ src/Holumbus/Crawler.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler+ ( module Holumbus.Crawler.Constants+ , module Holumbus.Crawler.Core+ , module Holumbus.Crawler.Html+ , module Holumbus.Crawler.Logger+ , module Holumbus.Crawler.Robots+ , module Holumbus.Crawler.RobotTypes+ , module Holumbus.Crawler.Types+ , module Holumbus.Crawler.URIs+ , module Holumbus.Crawler.Util+ , module Holumbus.Crawler.XmlArrows+ )+where++import Holumbus.Crawler.Constants+import Holumbus.Crawler.Core+import Holumbus.Crawler.Html+import Holumbus.Crawler.Logger+import Holumbus.Crawler.Robots+import Holumbus.Crawler.RobotTypes+import Holumbus.Crawler.Types+import Holumbus.Crawler.URIs+import Holumbus.Crawler.Util+import Holumbus.Crawler.XmlArrows++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/CacheCore.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.CacheCore+where++import Control.DeepSeq++import Data.Binary ( Binary(..) )+{-+import qualified Data.Binary as B+-- -}++import Data.Function.Selector++import Holumbus.Crawler++import Text.XML.HXT.Core+import Text.XML.HXT.Curl++-- ------------------------------------------------------------++type CacheCrawlerConfig = CrawlerConfig () CacheState+type CacheCrawlerState = CrawlerState CacheState++newtype CacheState = CS ()++-- ------------------------------------------------------------++-- If CacheState was declared as alias for () this would be redundant,+-- but this can be taken as a pattern for other crawlers++instance NFData CacheState where++instance Binary CacheState where+ put = const $ return ()+ get = return emptyCacheState++instance XmlPickler CacheState where+ xpickle = xpElem "cacheState" $+ xpWrap (const emptyCacheState, const ()) $+ xpUnit++-- ------------------------------------------------------------++emptyCacheState :: CacheState+emptyCacheState = CS ()++-- ------------------------------------------------------------++unionCacheStatesM :: (Monad m) => CacheState -> CacheState -> m CacheState+unionCacheStatesM _s1 _s2 = return emptyCacheState++insertCacheM :: (Monad m) => (URI, ()) -> CacheState -> m CacheState+insertCacheM _ _ = return emptyCacheState++-- ------------------------------------------------------------++-- the cache crawler configureation++cacheCrawlerConfig :: SysConfig -- ^ document read options+ -> (URI -> Bool) -- ^ the filter for deciding, whether the URI shall be processed+ -> CacheCrawlerConfig -- ^ result is a crawler config++cacheCrawlerConfig opts followRef+ = addSysConfig (defaultOpts >>> opts) -- install the default read options and+ >>> -- overwrite and add specific read options+ ( setS theFollowRef followRef )+ >>>+ ( setS theProcessRefs getHtmlReferences )+ >>>+ ( setS thePreDocFilter checkDocumentStatus ) -- in case of errors throw away any contents+ >>>+ ( setS theProcessDoc $ constA ())+ >>>+ enableRobotsTxt -- add the robots stuff at the end+ >>> -- the filter wrap the other filters+ addRobotsNoFollow+ >>>+ addRobotsNoIndex+ $+ defaultCrawlerConfig insertCacheM unionCacheStatesM+ -- take the default crawler config+ -- and set the result combining functions+ where+ defaultOpts = withCurl [ (curl_max_filesize, "1000000") -- limit document size to 1 Mbyte+ , (curl_location, v_1) -- automatically follow redirects+ , (curl_max_redirects, "3") -- but limit # of redirects to 3+ ]+ >>>+ withRedirect yes+ >>>+ withAcceptedMimeTypes ["text/html", "text/xhtml", "text/plain", "text/pdf"]+ >>>+ withInputEncoding isoLatin1+ >>>+ withEncodingErrors no -- encoding errors and parser warnings are boring+ >>>+ withValidate no+ >>>+ withParseHTML yes+ >>>+ withWarnings no++-- ------------------------------------------------------------++stdCacher :: (Int, Int, Int) -- ^ the parameters for parallel crawling + -> (Int, String) -- ^ the save intervall and file path+ -> (Priority, Priority) -- ^ the log levels for the crawler and hxt+ -> SysConfig -- ^ the read attributes+ -> (CacheCrawlerConfig -> CacheCrawlerConfig) -- ^ further configuration settings+ -> Maybe String -- ^ resume from interrupted index run with state stored in file+ -> [URI] -- ^ start caching with this set of uris+ -> (URI -> Bool) -> IO CacheCrawlerState++stdCacher (maxDocs, maxParDocs, maxParThreads)+ (saveIntervall, savePath)+ (trc, trcx)+ inpOptions+ furtherConfigs+ resumeLoc+ startUris+ followRef = execCrawler action config initState+ where+ initState = initCrawlerState emptyCacheState+ action = do+ noticeC "cacheCore" ["cache update started"]+ maybe (crawlDocs startUris) crawlerResume $ resumeLoc+ noticeC "cacheCore" ["cache update finished"]++ config = setCrawlerMaxDocs maxDocs maxParDocs maxParThreads+ >>>+ setCrawlerSaveConf saveIntervall savePath+ >>>+ setCrawlerTraceLevel trc trcx+ >>>+ enableRobotsTxt -- change to disableRobotsTxt, when robots.txt becomes boring+ >>>+ furtherConfigs+ $+ cacheCrawlerConfig inpOptions followRef++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/Constants.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.Constants+where++defaultCrawlerName :: String+defaultCrawlerName = "HolumBot/1.1 @http://holumbus.fh-wedel.de -" ++ "-location"++curl_user_agent :: String+curl_user_agent = "curl-" ++ "-user-agent"++curl_max_time :: String+curl_max_time = "curl-" ++ "-max-time"++curl_connect_timeout :: String+curl_connect_timeout = "curl-" ++ "-connect-timeout"++curl_max_filesize :: String+curl_max_filesize = "curl-" ++ "-max-filesize"++curl_location :: String+curl_location = "curl-" ++ "-location"++curl_max_redirects :: String+curl_max_redirects = "curl-" ++ "-max-redirs"++http_location :: String+http_location = "http-location"++http_last_modified :: String+http_last_modified = "http-Last-Modified"++-- ------------------------------------------------------------+
+ src/Holumbus/Crawler/Core.hs view
@@ -0,0 +1,391 @@+{-# OPTIONS -XBangPatterns #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.Core+where++import Control.Concurrent.MapFold ( mapFold )+import Control.Sequential.MapFoldBinary ( mapFoldBinaryM )+import Control.DeepSeq++import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.ReaderStateIO++import Data.Binary ( Binary )+import qualified Data.Binary as B -- else naming conflict with put and get from Monad.State++import Data.Function.Selector++import Data.List++import Holumbus.Crawler.Constants+import Holumbus.Crawler.Logger+import Holumbus.Crawler.URIs+import Holumbus.Crawler.Robots+import Holumbus.Crawler.Types+import Holumbus.Crawler.Util ( mkTmpFile )+import Holumbus.Crawler.XmlArrows++import Text.XML.HXT.Core hiding+ ( when+ , getState+ )++-- ------------------------------------------------------------++saveCrawlerState :: (Binary r) => FilePath -> CrawlerAction a r ()+saveCrawlerState fn = do preSave+ s <- get+ liftIO $ B.encodeFile fn s+ where+ preSave = do act <- getConf theSavePreAction+ act fn++loadCrawlerState :: (Binary r) => FilePath -> CrawlerAction a r ()+loadCrawlerState fn = do+ s <- liftIO $ B.decodeFile fn+ put s+++uriProcessed :: URI -> CrawlerAction a r ()+uriProcessed uri = do+ modifyState theToBeProcessed $ deleteURI uri+ modifyState theAlreadyProcessed $ insertURI uri++urisProcessed :: URIs -> CrawlerAction a r ()+urisProcessed uris = do+ modifyState theToBeProcessed $ deleteURIs uris+ modifyState theAlreadyProcessed $ flip unionURIs uris++uriToBeProcessed :: URI -> Int -> CrawlerAction a r ()+uriToBeProcessed uri level = do+ aps <- getState theAlreadyProcessed+ when ( not $ uri `memberURIs` aps )+ ( modifyState theToBeProcessed $ insertURI' uri level)++urisToBeProcessed :: URIsWithLevel -> CrawlerAction a r ()+urisToBeProcessed uris = do+ aps <- getState theAlreadyProcessed+ let newUris = deleteURIs aps uris+ modifyState theToBeProcessed $ flip (unionURIs' min) newUris++uriAddToRobotsTxt :: URI -> CrawlerAction a r ()+uriAddToRobotsTxt uri = do+ conf <- ask+ let raa = getS theAddRobotsAction conf+ modifyStateIO theRobots (raa conf uri)++accumulateRes :: (NFData r) => (URI, a) -> CrawlerAction a r ()+accumulateRes res = do+ combine <- getConf theAccumulateOp+ acc0 <- getState theResultAccu+ acc1 <- liftIO $ combine res acc0+ putState theResultAccu acc1++-- ------------------------------------------------------------++crawlDocs :: (NFData a, NFData r, Binary r) => [URI] -> CrawlerAction a r ()+crawlDocs uris = do+ noticeC "crawlDocs" ["init crawler state and start crawler loop"]+ putState theToBeProcessed (fromListURIs' $ zip uris (repeat 0))+ crawlerLoop+ noticeC "crawlDocs" ["crawler loop finished"]+ crawlerSaveState++crawlerLoop :: (NFData a, NFData r, Binary r) => CrawlerAction a r ()+crawlerLoop = do+ n <- getState theNoOfDocs+ m <- getConf theMaxNoOfDocs+ t <- getConf theMaxParThreads+ when (n < m)+ ( do+ noticeC "crawlerLoop" ["iteration", show $ n+1]+ tbp <- getState theToBeProcessed+ noticeC "crawlerLoop" [show $ cardURIs tbp, "uri(s) remain to be processed"]+ when (not . nullURIs $ tbp)+ ( do+ case t of+ 0 -> crawlNextDoc -- sequential crawling+ 1 -> crawlNextDocs mapFoldBinaryM -- sequential crawling with binary mapFold+ _ -> crawlNextDocs (mapFold t) -- parallel mapFold crawling+ crawlerCheckSaveState+ crawlerLoop+ )+ )++crawlerResume :: (NFData a, NFData r, Binary r) => String -> CrawlerAction a r ()+crawlerResume fn = do+ noticeC "crawlerResume" ["read crawler state from", fn]+ loadCrawlerState fn+ noticeC "crawlerResume" ["resume crawler"]+ crawlerLoop++crawlerCheckSaveState :: Binary r => CrawlerAction a r ()+crawlerCheckSaveState = do+ n1 <- getState theNoOfDocs+ n0 <- getState theNoOfDocsSaved+ m <- getConf theSaveIntervall+ when ( m > 0 && n1 - n0 >= m)+ crawlerSaveState++crawlerSaveState :: Binary r => CrawlerAction a r ()+crawlerSaveState = do+ n1 <- getState theNoOfDocs+ n0 <- getState theNoOfDocsSaved+ when (n1 > n0) -- else state has already been saved, don't do it twice+ ( do+ fn <- getConf theSavePathPrefix+ let fn' = mkTmpFile 10 fn n1+ noticeC "crawlerSaveState" [show n1, "documents into", show fn']+ putState theNoOfDocsSaved n1+ modifyState theListOfDocsSaved (n1 :)+ saveCrawlerState fn'+ noticeC "crawlerSaveState" ["saving state finished"]+ )++-- ------------------------------------------------------------++type MapFold a r = (a -> IO r) -> (r -> r -> IO r) -> [a] -> IO r++crawlNextDocs :: (NFData r) => MapFold URIWithLevel (URIs, URIsWithLevel, r) -> CrawlerAction a r ()+crawlNextDocs mapf = do+ uris <- getState theToBeProcessed+ nd <- getState theNoOfDocs++ mp <- getConf theMaxParDocs+ md <- getConf theMaxNoOfDocs++ let n = mp `min` (md - nd) + let urisTBP = nextURIs n uris++ modifyState theNoOfDocs (+ (length urisTBP))++ noticeC "crawlNextDocs" ["next", show (length urisTBP), "uri(s) will be processed"]++ urisProcessed $ fromListURIs $ map fst urisTBP+ urisAllowed <- filterM (isAllowedByRobots . fst) urisTBP++ when (not . null $ urisAllowed) $+ do+ conf <- ask+ let mergeOp = getS theFoldOp conf++ state' <- get+ ( ! urisMoved,+ ! urisNew,+ ! results+ ) <- liftIO $+ mapf (processCmd conf state') (combineDocResults' mergeOp) $+ urisAllowed++ noticeC "crawlNextDocs" [show . cardURIs $ urisNew, "hrefs found, accumulating results"]+ mapM_ (debugC "crawlNextDocs") $ map (("href" :) . (:[])) $ toListURIs urisNew+ urisProcessed urisMoved+ urisToBeProcessed urisNew+ acc0 <- getState theResultAccu+ ! acc1 <- liftIO $ mergeOp results acc0+ putState theResultAccu acc1+ noticeC "crawlNextDocs" ["document results accumulated"]++ where+ processCmd c s u = do+ noticeC "processCmd" ["processing document:", show u]+ ((m1, n1, rawRes), _) <- runCrawler (processDoc' u) c s+ r1 <- foldM (flip accOp) res0 rawRes+ rnf r1 `seq` rnf m1 `seq` rnf r1 `seq`+ noticeC "processCmd" ["document processed: ", show u]+ return (m1, n1, r1)+ where+ res0 = getS theResultInit s+ accOp = getS theAccumulateOp c++-- ------------------------------------------------------------++processDoc' :: URIWithLevel -> CrawlerAction a r (URIs, URIsWithLevel, [(URI, a)])+processDoc' (uri, lev) = do+ conf <- ask+ [(uri', (uris', docRes))] <- liftIO $ runX (processDocArrow conf uri)+ let toBeFollowed = getS theFollowRef conf+ let maxLevel = getS theClickLevel conf+ let ! lev1 = lev + 1 + let movedUris = if null uri'+ then emptyURIs+ else singletonURIs uri'+ let newUris = if lev >= maxLevel+ then emptyURIs+ else fromListURIs'+ . map (\ u -> (u, lev1)) + . filter toBeFollowed+ $ uris'+ return (movedUris, newUris, docRes)++-- ------------------------------------------------------------++combineDocResults' :: (NFData r) =>+ MergeDocResults r ->+ (URIs, URIsWithLevel, r) ->+ (URIs, URIsWithLevel, r) -> IO (URIs, URIsWithLevel, r)+combineDocResults' mergeOp (m1, n1, r1) (m2, n2, r2)+ = do+ noticeC "crawlNextDocs" ["combining results"]+ r <- mergeOp r1 r2+ m <- return $ unionURIs m1 m2+ n <- return $ unionURIs' min n1 n2+ res <- return $ (m, n, r)+ rnf res `seq`+ noticeC "crawlNextDocs" ["results combined"]+ return res++-- ------------------------------------------------------------+--+-- | crawl a single doc, mark doc as processed, collect new hrefs and combine doc result with accumulator in state++crawlNextDoc :: (NFData a, NFData r) => CrawlerAction a r ()+crawlNextDoc = do+ uris <- getState theToBeProcessed+ modifyState theNoOfDocs (+1)+ let uri@(u, _lev) = nextURI uris+ noticeC "crawlNextDoc" [show uri]+ uriProcessed u -- uri is put into processed URIs+ isGood <- isAllowedByRobots u+ when isGood $+ do+ res <- processDoc uri -- get document and extract new refs and result+ let (uri', uris', resList') = rnf res `seq` res -- force evaluation++ when (not . null $ uri') $+ uriProcessed uri' -- doc has been moved, uri' is real uri, so it's also put into the set of processed URIs++ noticeC "crawlNextDoc" [show . length . nub . sort $ uris', "new uris found"]+ mapM_ (uncurry uriToBeProcessed) uris' -- insert new uris into toBeProcessed set+ mapM_ accumulateRes resList' -- combine results with state accu++-- | Run the process document arrow and prepare results++processDoc :: URIWithLevel -> CrawlerAction a r (URI, [URIWithLevel], [(URI, a)])+processDoc (uri, lev) = do+ conf <- ask+ let maxLevel = getS theClickLevel conf+ let ! lev1 = lev + 1+ [(uri', (uris, res))] <- liftIO $ runX (processDocArrow conf uri)+ let newUris = if lev >= maxLevel+ then []+ else map (\ u -> (u, lev1))+ . filter (getS theFollowRef conf)+ $ uris+ return ( if uri' /= uri+ then uri'+ else ""+ , newUris+ , res -- usually in case of normal processing this is a singleton list+ )+ -- and in case of an error it's an empty list+-- ------------------------------------------------------------++-- | filter uris rejected by robots.txt++isAllowedByRobots :: URI -> CrawlerAction a r Bool+isAllowedByRobots uri = do+ uriAddToRobotsTxt uri -- for the uri host, a robots.txt is loaded, if neccessary+ rdm <- getState theRobots+ if (robotsDisallow rdm uri) -- check, whether uri is disallowed by host/robots.txt+ then do+ noticeC "isAllowedByRobot" ["uri rejected by robots.txt", show uri]+ return False+ else do+ -- noticeC "isAllowedByRobot" ["uri allowed by robots.txt", show uri]+ return True++-- ------------------------------------------------------------++-- | From a document two results are computed, 1. the list of all hrefs in the contents,+-- and 2. the collected info contained in the page. This result is augmented with the transfer uri+-- such that following functions know the source of this contents. The transfer-URI may be another one+-- as the input uri, there could happen a redirect in the http request.+--+-- The two listA arrows make the whole arrow deterministic, so it never fails++processDocArrow :: CrawlerConfig c r -> URI -> IOSArrow a (URI, ([URI], [(URI, c)]))++processDocArrow c uri = ( hxtSetTraceAndErrorLogger (getS theTraceLevelHxt c)+ >>>+ readDocument [getS theSysConfig c] uri+ >>>+ perform ( ( getAttrValue transferStatus+ &&&+ getAttrValue transferMessage+ )+ >>>+ ( arr2 $ \ s m -> unwords ["processDocArrow: response code:", s, m] )+ >>>+ traceString 1 id+ )+ >>>+ ( getRealDocURI+ &&&+ listA ( checkDocumentStatus+ >>>+ getS thePreRefsFilter c+ >>>+ getS theProcessRefs c+ )+ &&&+ listA ( getS thePreDocFilter c+ >>>+ ( getAttrValue transferURI+ &&&+ getS theProcessDoc c+ )+ )+ )+ )+ `withDefault` ("", ([], []))++-- ------------------------------------------------------------++-- | compute the real URI in case of a 301 or 302 response (moved permanently or temporary),+-- else the arrow will fail++getLocationReference :: ArrowXml a => a XmlTree String+getLocationReference = fromLA $+ ( getAttrValue0 transferStatus+ >>>+ isA (`elem` ["301", "302"])+ )+ `guards`+ getAttrValue0 http_location++-- | compute the real URI of the document, in case of a move response+-- this is contained in the \"http-location\" attribute, else it's the+-- tranferURI.++getRealDocURI :: ArrowXml a => a XmlTree String+getRealDocURI = fromLA $+ getLocationReference+ `orElse`+ getAttrValue transferURI++-- ------------------------------------------------------------++initCrawler :: CrawlerAction a r ()+initCrawler = do+ conf <- ask+ setLogLevel "" (getS theTraceLevel conf)+ ++runCrawler :: CrawlerAction a r x ->+ CrawlerConfig a r ->+ CrawlerState r -> IO (x, CrawlerState r)+runCrawler a = runReaderStateIO (initCrawler >> a)++-- run a crawler and deliver just the accumulated result value++execCrawler :: CrawlerAction a r x ->+ CrawlerConfig a r ->+ CrawlerState r -> IO (CrawlerState r)+execCrawler cmd config initState+ = runCrawler cmd config initState >>= return . snd++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/Html.hs view
@@ -0,0 +1,195 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.Html+where++import Data.Function.Selector++import Data.List+import Data.Maybe++import Holumbus.Crawler.Types+import Holumbus.Crawler.URIs++import System.FilePath++import Text.XML.HXT.Core hiding ( when+ , getState+ )+{- just for debugging+import qualified Debug.Trace as D+-- -}+-- ------------------------------------------------------------++defaultHtmlCrawlerConfig :: AccumulateDocResult a r ->+ MergeDocResults r -> CrawlerConfig a r+defaultHtmlCrawlerConfig op op2 = ( setS theSysConfig+ ( withValidate no+ >>>+ withParseHTML yes+ >>>+ withInputEncoding isoLatin1+ >>>+ withWarnings no+ >>>+ withIgnoreNoneXmlContents yes+ )+ >>>+ setS thePreRefsFilter this+ >>>+ setS theProcessRefs getHtmlReferences+ $ + defaultCrawlerConfig op op2+ )++-- ------------------------------------------------------------++-- | Collect all HTML references to other documents within a, frame and iframe elements++getHtmlReferences :: ArrowXml a => a XmlTree URI+getHtmlReferences = fromLA (getRefs $< computeDocBase)+ where+ getRefs base = deep (hasNameWith+ ( (`elem` ["a","frame","iframe"]) . localPart )+ )+ >>>+ ( getAttrValue0 "href"+ <+>+ getAttrValue0 "src"+ )+ >>^ toAbsRef base++getDocReferences :: ArrowXml a => a XmlTree URI+getDocReferences = fromLA (getRefs $< computeDocBase)+ where+ getRefs base = multi selRefs >>^ toAbsRef base+ where+ hasLocName n = hasNameWith ((== n) . localPart)+ selRef en an = hasLocName en :-> getAttrValue0 an+ selRefs = choiceA $+ map (uncurry selRef) names+ +++ [ appletRefs+ , objectRefs+ , this :-> none+ ]+ names = [ ("img", "src")+ , ("input", "src") -- input type="image" scr="..."+ , ("link", "href")+ , ("script", "src")+ ] + appletRefs = hasLocName "applet" :-> (getAppRef $< getAppBase)+ where+ getAppBase = (getAttrValue0 "codebase" `withDefault` ".") >>^ toAbsRef base+ getAppRef ab = getAttrValue0 "code" >>^ toAbsRef ab++ objectRefs = hasLocName "object" :-> none -- TODO++-- | construct an absolute URI by a base URI and a possibly relative URI++toAbsRef :: URI -> URI -> URI+toAbsRef base ref = ( expandURIString ref -- here >>> is normal function composition+ >>>+ fromMaybe ref+ >>>+ removeFragment+ ) base+ where+ removeFragment r+ | "#" `isPrefixOf` path = reverse . tail $ path+ | otherwise = r+ where+ path = dropWhile (/='#') . reverse $ r ++-- ------------------------------------------------------------++-- | Compute the base URI of a HTML page with respect to a possibly+-- given base element in the head element of a html page.+--+-- Stolen from Uwe Schmidt, http:\/\/www.haskell.org\/haskellwiki\/HXT+-- and then stolen back again by Uwe from Holumbus.Utility++computeDocBase :: ArrowXml a => a XmlTree String+computeDocBase = ( ( ( getByPath ["html", "head", "base"]+ >>>+ getAttrValue "href" -- and compute document base with transfer uri and base+ )+ &&&+ getAttrValue transferURI+ )+ >>> expandURI+ )+ `orElse`+ getAttrValue transferURI -- the default: take the transfer uri++-- ------------------------------------------------------------++getByPath :: ArrowXml a => [String] -> a XmlTree XmlTree+getByPath = seqA . map (\ n -> getChildren >>> hasName n)++getHtmlTitle :: ArrowXml a => a XmlTree String+getHtmlTitle = getAllText $+ getByPath ["html", "head", "title"]++getHtmlPlainText :: ArrowXml a => a XmlTree String+getHtmlPlainText = getAllText $+ getByPath ["html", "body"]++getAllText :: ArrowXml a => a XmlTree XmlTree -> a XmlTree String+getAllText getText' = ( getText'+ >>>+ ( fromLA $ deep getText )+ >>^+ (" " ++) -- text parts are separated by a space+ )+ >. (concat >>> normalizeWS) -- normalize Space++isHtmlContents :: ArrowXml a => a XmlTree XmlTree+isHtmlContents = ( getAttrValue transferMimeType+ >>>+ isA ( `elem` [text_html, application_xhtml] )+ ) `guards` this++isPdfContents :: ArrowXml a => a XmlTree XmlTree+isPdfContents = ( getAttrValue transferMimeType+ >>>+ isA ( == application_pdf )+ ) `guards` this++getTitleOrDocName :: ArrowXml a => a XmlTree String+getTitleOrDocName = ( getHtmlTitle >>> isA (not . null) )+ `orElse`+ ( getAttrValue transferURI >>^ takeFileName )++isElemWithAttr :: ArrowXml a => String -> String -> (String -> Bool) -> a XmlTree XmlTree+isElemWithAttr en an av = isElem+ >>>+ hasName en+ >>>+ hasAttrValue an av++-- ------------------------------------------------------------++application_pdf :: String+application_pdf = "application/pdf"++-- ------------------------------------------------------------++-- | normalize whitespace by splitting a text into words and joining this together with unwords++normalizeWS :: String -> String+normalizeWS = words >>> unwords++-- | take the first n chars of a string, if the input+-- is too long the cut off is indicated by \"...\" at the end++limitLength :: Int -> String -> String+limitLength n s+ | length s' <= n = s+ | otherwise = take (n - 3) s' ++ "..."+ where+ s' = take (n + 1) s++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/IndexerCore.hs view
@@ -0,0 +1,281 @@+{-# OPTIONS -XFlexibleContexts -XBangPatterns #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.IndexerCore+ ( RawDoc+ , RawContexts+ , RawContext+ , RawWords+ , RawWord+ , RawTitle+ , IndexCrawlerConfig+ , IndexContextConfig(..)+ , IndexerState(..)+ , emptyIndexerState+ , indexCrawlerConfig+ , stdIndexer+ , unionIndexerStatesM+ , insertRawDocM+ )+where++-- ------------------------------------------------------------++import Control.DeepSeq+import Control.Monad ( foldM )+import Control.Monad.Trans -- ( MonadIO )++import Data.Binary ( Binary )+import qualified Data.Binary as B+import Data.Function.Selector+import Data.Maybe++import Holumbus.Crawler++import Holumbus.Index.Common hiding ( URI )++import Text.XML.HXT.Core++-- ------------------------------------------------------------++type RawDoc c = (RawContexts, RawTitle, Maybe c) -- c is the user defined custom info+type RawContexts = [RawContext]+type RawContext = (Context, RawWords)+type RawWords = [RawWord]+type RawWord = (Word, Position)+type RawTitle = String++type IndexCrawlerConfig i d c = CrawlerConfig (RawDoc c) (IndexerState i d c)+type IndexCrawlerState i d c = CrawlerState (IndexerState i d c)++data IndexContextConfig = IndexContextConfig+ { ixc_name :: String+ , ixc_collectText :: IOSArrow XmlTree String+ , ixc_textToWords :: String -> [String]+ , ixc_boringWord :: String -> Bool+ } ++data IndexerState i d c = IndexerState+ { ixs_index :: ! i -- the index type+ , ixs_documents :: ! (d c) -- the type for document descriptions+ } deriving (Show)++-- ------------------------------------------------------------++instance (NFData i, NFData (d c)) => NFData (IndexerState i d c)+ where+ rnf IndexerState { ixs_index = i+ , ixs_documents = d+ } = rnf i `seq` rnf d++-- ------------------------------------------------------------++instance (Binary i, Binary (d c)) => Binary (IndexerState i d c)+ where+ put s = B.put (ixs_index s)+ >>+ B.put (ixs_documents s)+ get = do+ ix <- B.get+ dm <- B.get+ return $ IndexerState+ { ixs_index = ix+ , ixs_documents = dm+ }++-- ------------------------------------------------------------++instance (XmlPickler i, XmlPickler (d c)) => XmlPickler (IndexerState i d c)+ where+ xpickle = xpElem "index-state" $+ xpWrap ( uncurry IndexerState+ , \ ix -> (ixs_index ix, ixs_documents ix)+ ) $+ xpPair xpickle xpickle++-- ------------------------------------------------------------++emptyIndexerState :: i -> d c -> IndexerState i d c+emptyIndexerState eix edm = IndexerState+ { ixs_index = eix+ , ixs_documents = edm+ }++-- ------------------------------------------------------------++stdIndexer :: ( Binary i+ , Binary (d c)+ , Binary c+ , HolIndexM IO i+ , HolDocuments d c+ , NFData i+ , NFData (d c)+ , NFData c) =>+ IndexCrawlerConfig i d c -- ^ adapt configuration to special needs,+ -- use id if default is ok+ -> Maybe String -- ^ resume from interrupted index run with state+ -- stored in file+ -> [URI] -- ^ start indexing with this set of uris+ -> IndexerState i d c -- ^ the initial empty indexer state+ -> IO (IndexCrawlerState i d c) -- ^ result is a state consisting of the index and the map of indexed documents++stdIndexer config resumeLoc startUris eis+ = execCrawler action config (initCrawlerState eis)+ where+ action = do+ noticeC "indexerCore" ["indexer started"]+ res <- maybe (crawlDocs startUris) crawlerResume $ resumeLoc+ noticeC "indexerCore" ["indexer finished"]+ return res++-- ------------------------------------------------------------++-- general HolIndexM IO i version, for old specialized version see code at end of this file++indexCrawlerConfig :: ( HolIndexM IO i+ , HolDocuments d c+ , HolDocIndex d c i+ , NFData i+ , NFData c+ , NFData (d c)+ ) =>+ SysConfig -- ^ document read options+ -> (URI -> Bool) -- ^ the filter for deciding, whether the URI shall be processed+ -> Maybe (IOSArrow XmlTree String) -- ^ the document href collection filter, default is 'Holumbus.Crawler.Html.getHtmlReferences'+ -> Maybe (IOSArrow XmlTree XmlTree) -- ^ the pre document filter, default is the this arrow+ -> Maybe (IOSArrow XmlTree String) -- ^ the filter for computing the document title, default is empty string+ -> Maybe (IOSArrow XmlTree c) -- ^ the filter for the cutomized doc info, default Nothing+ -> [IndexContextConfig] -- ^ the configuration of the various index parts+ -> IndexCrawlerConfig i d c -- ^ result is a crawler config++indexCrawlerConfig opts followRef getHrefF preDocF titleF0 customF0 contextCs+ = addSysConfig (defaultOpts >>> opts) -- install the default read options+ >>>+ ( setS theFollowRef followRef )+ >>>+ ( setS theProcessRefs $ fromMaybe getHtmlReferences getHrefF )+ >>>+ ( setS thePreDocFilter $ fromMaybe checkDocumentStatus preDocF ) -- in case of errors throw away any contents+ >>>+ ( setS theProcessDoc rawDocF ) -- rawDocF is build up by the context config, text, title and custom+ >>>+ enableRobotsTxt -- add the robots stuff at the end+ >>> -- the filter wrap the other filters+ addRobotsNoFollow+ >>>+ addRobotsNoIndex+ $+ defaultCrawlerConfig insertRawDocM unionIndexerStatesM+ -- take the default crawler config+ -- and set the result combining functions+ where+ rawDocF = ( listA contextFs+ &&&+ titleF+ &&&+ customF+ )+ >>^ (\ (x3, (x2, x1)) -> (x3, x2, x1))++ titleF = ( fromMaybe (constA "") titleF0 ) >. concat++ customF = ( fromMaybe none customF0 ) >. listToMaybe+ + contextFs :: IOSArrow XmlTree RawContext+ contextFs = catA . map contextF $ contextCs -- collect all contexts++ contextF :: IndexContextConfig -> IOSArrow XmlTree RawContext+ contextF ixc = constA (ixc_name ixc) -- the name of the raw context+ &&&+ ( ixc_collectText ixc >. processText ) -- the list of words and positions of the collected text+ where -- this arrow is deterministic, it always delivers a single pair+ processText :: [String] -> RawWords+ processText = concat+ >>>+ ixc_textToWords ixc+ >>>+ flip zip [1..]+ >>>+ filter (fst >>> ixc_boringWord ixc >>> not)++ defaultOpts = withRedirect yes+ >>>+ withAcceptedMimeTypes ["text/html", "text/xhtml"]+ >>>+ withInputEncoding isoLatin1+ >>>+ withEncodingErrors no -- encoding errors and parser warnings are boring+ >>>+ withValidate no+ >>>+ withParseHTML yes+ >>>+ withWarnings no++-- ------------------------------------------------------------++unionIndexerStatesM :: ( MonadIO m+ , HolIndexM m i+ , HolDocuments d c+ , HolDocIndex d c i+ ) =>+ IndexerState i d c+ -> IndexerState i d c+ -> m (IndexerState i d c)+unionIndexerStatesM ixs1 ixs2+ = return+ $! IndexerState { ixs_index = ix+ , ixs_documents = dt+ }+ where+ (! dt, ! ix) = unionDocIndex dt1 ix1 dt2 ix2+ ix1 = ixs_index ixs1+ ix2 = ixs_index ixs2+ dt1 = ixs_documents ixs1+ dt2 = ixs_documents ixs2++-- ------------------------------------------------------------++insertRawDocM :: ( MonadIO m+ , HolIndexM m i+ , HolDocuments d c+ , NFData i+ , NFData c+ , NFData (d c)+ ) =>+ (URI, RawDoc c) -- ^ extracted URI and doc info+ -> IndexerState i d c -- ^ old indexer state+ -> m (IndexerState i d c) -- ^ new indexer state++insertRawDocM (rawUri, (rawContexts, rawTitle, rawCustom)) ixs+ | nullContexts = return ixs -- no words found in document,+ -- so there are no refs in index+ -- and document is thrown away+ | otherwise = do+ newIx <- foldM (insertRawContextM did) (ixs_index ixs) $ rawContexts+ newIxs <- return $+ IndexerState { ixs_index = newIx+ , ixs_documents = newDocs+ }+ rnf newIxs `seq`+ return newIxs+ where+ nullContexts = and . map (null . snd) $ rawContexts+ (did, newDocs) = insertDoc (ixs_documents ixs) doc+ doc = Document+ { title = rawTitle+ , uri = rawUri+ , custom = rawCustom+ }++insertRawContextM :: (Monad m, HolIndexM m i) =>+ DocId -> i -> (Context, [(Word, Position)]) -> m i+insertRawContextM did ix (cx, ws)+ = foldM (insWordM cx did) ix ws++insWordM :: (Monad m, HolIndexM m i) =>+ Context -> DocId -> i -> (Word, Position) -> m i+insWordM cx' did' ix' (w', p') = insertPositionM cx' w' did' p' ix'++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/Logger.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.Logger+ ( hxtLoggerName+ , hxtSetTraceAndErrorLogger+ , hxtSetLogLevel+ , hxtSetErrorLog++ , module System.Log.Logger++ , logC+ , noticeC+ , infoC+ , debugC+ , warnC+ , errC++ , setLogLevel+ )+where++import Control.Monad.Trans++import Data.List ( isPrefixOf )++import System.Log.Logger++import Text.XML.HXT.Core++crawlLoggerName :: String+crawlLoggerName = "crawl2"++hxtLoggerName :: String+hxtLoggerName = "hxt"++-- ------------------------------------------------------------++-- | Set trace level in config++logC :: MonadIO m => String -> Priority -> [String] -> m ()+logC logName' priority msg = liftIO $ logC' logName' priority msg++noticeC+ , infoC+ , debugC+ , warnC+ , errC :: MonadIO m => String -> [String] -> m ()++noticeC n = logC n NOTICE+infoC n = logC n INFO+debugC n = logC n DEBUG+warnC n = logC n WARNING+errC n = logC n ERROR++setLogLevel :: MonadIO m => String -> Priority -> m ()+setLogLevel logName' priority = liftIO $ setLogLevel' logName' priority++setLogLevel' :: String -> Priority -> IO ()+setLogLevel' logName' priority = updateGlobalLogger (realLogName logName') (setLevel priority)++-- ------------------------------------------------------------++realLogName :: String -> String+realLogName logName+ | null logName = crawlLoggerName+ | otherwise = crawlLoggerName ++ "." ++ logName+++logC' :: String -> Priority -> [String] -> IO ()+logC' logName' priority msg = logM logName priority msg'+ where+ logName = realLogName logName'+ msg' = fillName 23 logName ++ " " +++ fillName 9 (show priority) ++ " " +++ unwords msg++fillName :: Int -> String -> String+fillName n s = s ++ replicate b ' '+ where+ b = (n - length s) `max` 0++-- ------------------------------------------------------------++hxtLogger :: Int -> String -> IO ()+hxtLogger level msg = logC' hxtLoggerName priority [msg']+ where+ msg'+ | "-- (" `isPrefixOf` msg = drop 7 msg+ | otherwise = msg++ priority = toPriority level++ toPriority l+ | l <= 0 = NOTICE -- trace level 0 is issued as NOTICE, not as WARNING+ | l == 1 = NOTICE+ | l == 2 = INFO+ | otherwise = DEBUG -- level >= 3+ +hxtSetTraceAndErrorLogger :: Priority -> IOStateArrow s b b+hxtSetTraceAndErrorLogger priority+ = hxtSetLogLevel priority+ >>>+ hxtSetErrorLog++hxtSetLogLevel :: Priority -> IOStateArrow s b b+hxtSetLogLevel priority+ = setTraceLevel (fromPriority priority)+ >>>+ setTraceCmd hxtLogger+ >>>+ perform ( arrIO0 $+ updateGlobalLogger hxtLoggerName (setLevel priority)+ )+ where+ fromPriority NOTICE = 1+ fromPriority INFO = 2+ fromPriority DEBUG = 3+ fromPriority _ = 0++hxtSetErrorLog :: IOStateArrow s b b+hxtSetErrorLog = setErrorMsgHandler False hxtErrorLogger++hxtErrorLogger :: String -> IO ()+hxtErrorLogger msg = logC' hxtLoggerName+ priority+ [drop 1 . dropWhile (/= ':') $ msg]+ where+ priority = prio . drop 1 $ msg+ prio m+ | "fatal" `isPrefixOf` m = CRITICAL+ | "error" `isPrefixOf` m = ERROR+ | "warning" `isPrefixOf` m = WARNING+ | otherwise = NOTICE++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/PdfToText.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.PdfToText+where++import qualified Control.Exception as CE++import qualified Data.ByteString.Lazy as BS+import Data.String.Unicode ( utf8ToUnicode )++import System.Directory ( getTemporaryDirectory+ , removeFile+ )+import System.FilePath ( (</>) )+import System.Process ( rawSystem )+import System.Posix.Process ( getProcessID )++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | Converstion of pdf data into plain text. The conversion is done+-- by calling an external program @pdftotext@ (contained in linux packages @xpdf@).+-- IO is done via the ByteString API.++pdfToText :: String -> IO String+pdfToText = pdfToTextBS . BS.pack . map (toEnum . fromEnum)++pdfToTextBS :: BS.ByteString -> IO String+pdfToTextBS inp = ( do+ td <- getTemporaryDirectory+ pid <- getProcessID+ let fn1 = fn td pid "pdfToText.pdf"+ let fn2 = fn td pid "pdfToText.txt"+ BS.writeFile fn1 inp+ _ <- rawSystem "pdftotext" ["-q", "-enc", "UTF-8", fn1, fn2]+ removeFile fn1+ res <- BS.readFile fn2+ BS.length res `seq`+ removeFile fn2++ return ( fst . utf8ToUnicode . map (toEnum . fromEnum) . BS.unpack $ res )+ ) `mycatch` ( const $ return "" )+ where+ fn d p f = d </> (show p ++ "-" ++ f)++ mycatch :: IO a -> (CE.SomeException -> IO a) -> IO a+ mycatch = CE.catch++pdfToTextA :: IOSArrow String String+pdfToTextA = perform ( traceString 2 (("pdfToTextA input:\n" ++) . take 128 . show) )+ >>>+ arrIO pdfToText+ >>>+ perform ( traceString 2 (( "pdfToText result:\n" ++ ) . take 128 . show) )++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/RobotTypes.hs view
@@ -0,0 +1,115 @@+-- ------------------------------------------------------------++module Holumbus.Crawler.RobotTypes+where++import Control.DeepSeq++import Data.Binary ( Binary )+import qualified Data.Binary as B+import Data.Char+import qualified Data.Map as M++import Holumbus.Crawler.URIs++import Text.XML.HXT.Core++{-+import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch++import qualified Debug.Trace as D+-}++-- ------------------------------------------------------------++type Robots = M.Map URI RobotRestriction+type RobotRestriction = [RobotSpec]+type RobotSpec = (URI, RobotAction)++data RobotAction = Disallow | Allow+ deriving (Eq, Show, Read, Enum)++type AddRobotsAction = URI -> Robots -> IO Robots++-- ------------------------------------------------------------++instance Binary RobotAction where+ put = B.put . fromEnum+ get = do+ b <- B.get+ return (toEnum b)++instance NFData RobotAction where+ rnf x = x `seq` ()++instance XmlPickler RobotAction where+ xpickle = xpPrim++xpRobots :: PU Robots+xpRobots = xpElem "robots" $+ xpMap "robot" "host" xpText xpRobotRestriction++xpRobotRestriction :: PU RobotRestriction+xpRobotRestriction = xpList $+ xpElem "restriction" $+ xpPair ( xpAttr "href" $ xpText )+ ( xpAttr "access" $ xpickle )++-- ------------------------------------------------------------++emptyRobots :: Robots+emptyRobots = M.singleton "" []++robotsExtend :: String -> AddRobotsAction+robotsExtend _robotName _uri robots+ = return robots -- TODO++robotsIndex :: URI -> Robots -> Bool+robotsIndex _uri _robots+ = True -- TODO++robotsFollow :: URI -> Robots -> Bool+robotsFollow _uri _robots+ = True -- TODO++-- ------------------------------------------------------------++robotsNo :: String -> LA XmlTree XmlTree+robotsNo what = none+ `when`+ ( this+ /> hasName "html"+ /> hasName "head"+ /> hasName "meta" -- getByPath ["html", "head", "meta"]+ >>>+ hasAttrValue "name" ( map toUpper+ >>>+ (== "ROBOTS")+ )+ >>>+ getAttrValue0 "content"+ >>>+ isA ( map (toUpper+ >>>+ (\ x -> if isLetter x then x else ' ')+ )+ >>>+ words+ >>>+ (what `elem`)+ )+ ) ++-- | robots no index filter. This filter checks HTML documents+-- for a \<meta name=\"robots\" content=\"noindex\"\> in the head of the document++robotsNoIndex :: ArrowXml a => a XmlTree XmlTree+robotsNoIndex = fromLA $ robotsNo "NOINDEX"++-- | robots no follow filter. This filter checks HTML documents+-- for a \<meta name=\"robots\" content=\"nofollow\"\> in the head of the document++robotsNoFollow :: ArrowXml a => a XmlTree XmlTree+robotsNoFollow = fromLA $ robotsNo "NOFOLLOW"++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/Robots.hs view
@@ -0,0 +1,205 @@+-- ------------------------------------------------------------++module Holumbus.Crawler.Robots+where++import Control.DeepSeq++import Data.Function.Selector++import Data.List+import qualified Data.Map as M+import Data.Maybe++import Holumbus.Crawler.URIs+import Holumbus.Crawler.RobotTypes+import Holumbus.Crawler.Types+import Holumbus.Crawler.Logger++import qualified Network.URI as N++import Text.XML.HXT.Core+import Text.XML.HXT.Cache++{-+import Text.XML.HXT.RelaxNG.XmlSchema.RegexMatch++import qualified Debug.Trace as D+-}++-- ------------------------------------------------------------++-- | Add a robots.txt description for a given URI, if it's not already there.+-- The 1. main function of this module++robotsAddHost :: CrawlerConfig a r -> AddRobotsAction+robotsAddHost conf uri rdm+ | not (isRobotsScheme uri)+ = return rdm+ | isJust spec = return rdm+ | otherwise = do+ (h, r) <- robotsGetSpec conf host+ let rdm' = M.insert h r rdm+ return $! rdm'+ where+ host = getHost uri+ spec = M.lookup host rdm++-- ------------------------------------------------------------++robotsDontAddHost :: CrawlerConfig a r -> AddRobotsAction+robotsDontAddHost = const $ const return++-- ------------------------------------------------------------++-- | Check whether a robot is not allowed to access a page.+-- The 2. main function of this module++robotsDisallow :: Robots -> URI -> Bool+robotsDisallow rdm uri+ | not (isRobotsScheme uri)+ = False+ | isNothing restr = False+ | otherwise = evalRestr $ fromJust restr+ where+ host = getHost uri+ path' = getURIPart N.uriPath uri+ restr = M.lookup host rdm+ evalRestr = foldr isDis False+ where+ isDis (r, a) v+ | r `isPrefixOf` path'+ &&+ not (null r) = a == Disallow+ | otherwise = v++-- ------------------------------------------------------------++getURIPart :: (N.URI -> String) -> URI -> String+getURIPart f = maybe "" f+ .+ N.parseURIReference++-- | Get the protocol-host-port part of an URI++getHost :: URI -> URI+getHost = getURIPart h+ where+ h u = show $ u { N.uriPath = ""+ , N.uriQuery = ""+ , N.uriFragment = ""+ }++isRobotsScheme :: URI -> Bool+isRobotsScheme = (`elem` ["http:", "https:"]) . getURIPart N.uriScheme++-- ------------------------------------------------------------++-- | Access, parse and evaluate a robots.txt file for a given URI++robotsGetSpec :: CrawlerConfig a r -> URI -> IO (URI, RobotRestriction)+robotsGetSpec conf uri+ | not (isRobotsScheme uri)+ = return ("", [])+ | null host = return ("", [])+ | otherwise = do+ r <- getRobotsTxt conf host+ s <- return $ evalRobotsTxt agent r+ rnf s `seq` return (host, s)+ where+ host = getHost uri+ agent = getS theCrawlerName $ conf++-- ------------------------------------------------------------++-- | Try to get the robots.txt file for a given host.+-- If it's not there or any errors occur during access, the empty string is returned++getRobotsTxt :: CrawlerConfig c r -> URI -> IO String+getRobotsTxt c uri = runX processRobotsTxt >>= (return . concat)+ where+ processRobotsTxt = hxtSetTraceAndErrorLogger (getS theTraceLevelHxt c)+ >>>+ readDocument+ [ getS theSysConfig c+ >>>+ withParseByMimeType yes -- these 3 options are important for reading none XML/HTML documents+ >>>+ withIgnoreNoneXmlContents no+ >>>+ withAcceptedMimeTypes [text_plain] -- robots.txt is plain text+ >>>+ withRedirect yes -- follow redirects for robots.txt+ >>>+ withoutCache+ ] (getHost uri ++ "/robots.txt")+ >>>+ documentStatusOk+ >>>+ getChildren+ >>>+ getText++-- ------------------------------------------------------------++-- | Parse the robots.txt, select the crawler specific parts and build a robots restriction value++evalRobotsTxt :: String -> String -> RobotRestriction+evalRobotsTxt agent t = lines+ >>>+ map (takeWhile (/= '#') >>> stringTrim) -- remove comments and whitespace+ >>>+ filter (not . null)+ >>>+ filter ( stringToLower+ >>>+ takeWhile (/= ':')+ >>>+ (`elem` [ "disallow"+ , "allow"+ , "user-agent"+ , "crawl-delay"+ , "request-rate"+ , "visit-time"+ , "sitemap"+ ]+ )+ )+ >>>+ map ( span (/= ':')+ >>>+ ( stringToLower *** (drop 1 >>> stringTrim) )+ )+ >>>+ dropWhile ( \ (x, y) ->+ ( x /= "user-agent"+ ||+ ( y /= "*" && not (y `isPrefixOf` agent) )+ )+ )+ >>>+ drop 1+ >>>+ takeWhile (fst >>> (/= "user-agent"))+ >>>+ concatMap toRestr+ $+ t+ where+ toRestr ("disallow", uri) = [(uri, Disallow)] -- other directives are currently ignored+ toRestr ("allow", uri) = [(uri, Allow)]+ toRestr _ = []++-- ------------------------------------------------------------++-- | Enable the evaluation of robots.txt++enableRobotsTxt :: CrawlerConfig a r -> CrawlerConfig a r+enableRobotsTxt = setS theAddRobotsAction robotsAddHost++-- | Disable the evaluation of robots.txt++disableRobotsTxt :: CrawlerConfig a r -> CrawlerConfig a r+disableRobotsTxt = setS theAddRobotsAction robotsDontAddHost++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/Types.hs view
@@ -0,0 +1,426 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.Types+where++import Control.DeepSeq++import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.ReaderStateIO++-- import Control.Monad.State++import Data.Binary ( Binary )+import qualified Data.Binary as B -- else naming conflict with put and get from Monad.State++import Data.Function.Selector++import Holumbus.Crawler.Constants+import Holumbus.Crawler.URIs+import Holumbus.Crawler.RobotTypes+import Holumbus.Crawler.XmlArrows ( checkDocumentStatus )++import Text.XML.HXT.Core+import Text.XML.HXT.Curl+import qualified Text.XML.HXT.Arrow.XmlState.RunIOStateArrow as HXT ( theSysConfigComp )+import qualified Text.XML.HXT.Arrow.XmlState.TypeDefs as HXT ( theInputOptions )++import System.Log.Logger ( Priority(..) )++-- ------------------------------------------------------------++-- | The action to combine the result of a single document with the accumulator for the overall crawler result.+-- This combining function runs in the IO monad to enable storing parts of the result externally+-- but it is not a CrawlerAction, else parallel crawling with forkIO is not longer applicable++type AccumulateDocResult a r = (URI, a) -> r -> IO r++-- | The folding operator for merging partial results when working with mapFold and parallel crawling++type MergeDocResults r = r -> r -> IO r++-- | The operator for saving intermediate results++type SavePartialResults r = FilePath -> r -> IO r++-- | The extractor function for a single document++type ProcessDocument a = IOSArrow XmlTree a++-- | The crawler action monad++type CrawlerAction a r = ReaderStateIO (CrawlerConfig a r) (CrawlerState r)++-- | The crawler configuration record++data CrawlerConfig a r+ = CrawlerConfig+ { cc_sysConfig :: SysConfig+ , cc_preRefsFilter :: IOSArrow XmlTree XmlTree+ , cc_processRefs :: IOSArrow XmlTree URI+ , cc_preDocFilter :: IOSArrow XmlTree XmlTree+ , cc_processDoc :: ProcessDocument a+ , cc_accumulate :: AccumulateDocResult a r -- result accumulation runs in the IO monad to allow storing parts externally+ , cc_fold :: MergeDocResults r+ , cc_followRef :: URI -> Bool+ , cc_addRobotsTxt :: CrawlerConfig a r -> AddRobotsAction+ , cc_clickLevel :: ! Int+ , cc_maxNoOfDocs :: ! Int+ , cc_maxParDocs :: ! Int+ , cc_maxParThreads :: ! Int+ , cc_saveIntervall :: ! Int+ , cc_savePathPrefix :: ! String+ , cc_savePreAction :: FilePath -> CrawlerAction a r () -- SavePartialResults r+ , cc_traceLevel :: ! Priority+ , cc_traceLevelHxt :: ! Priority+ }++-- | The crawler state record++data CrawlerState r+ = CrawlerState+ { cs_toBeProcessed :: ! URIsWithLevel+ , cs_alreadyProcessed :: ! URIs+ , cs_robots :: ! Robots -- is part of the state, it will grow during crawling+ , cs_noOfDocs :: ! Int -- stop crawling when this counter reaches 0, (-1) means unlimited # of docs+ , cs_noOfDocsSaved :: ! Int+ , cs_listOfDocsSaved :: ! [Int]+ , cs_resultAccu :: ! r -- evaluate accumulated result, else memory leaks show up+ , cs_resultInit :: ! r -- the initial value for folding results+ }+ deriving (Show)++instance (NFData r) => NFData (CrawlerState r) where+ rnf CrawlerState { cs_toBeProcessed = a+ , cs_alreadyProcessed = b+ , cs_robots = c+ , cs_noOfDocs = d+ , cs_noOfDocsSaved = e+ , cs_listOfDocsSaved = f+ , cs_resultAccu = g+ , cs_resultInit = h+ } = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq`+ rnf e `seq` rnf f `seq` rnf g `seq` rnf h++instance (XmlPickler r) => XmlPickler (CrawlerState r) where+ xpickle = xpElem "crawler-state" $+ xpWrap ( \ ((d, e, f), (a, b, c, g, h)) -> CrawlerState a b c d e f g h+ , \ (CrawlerState a b c d e f g h) -> ( (d, e, f)+ , (a, b, c, g, h)+ )+ ) $+ xpPair ( xpTriple+ ( xpAttr "no-of-docs" xpPrim )+ ( xpAttr "no-of-docs-saved" xpPrim )+ ( xpAttr "list-of-docs-saved" $+ xpList $+ xpElem "saved-at" $+ xpPrim+ )+ )+ ( xp5Tuple+ ( xpElem "to-be-processed" $+ xpURIsWithLevel+ )+ ( xpElem "already-processed" $+ xpURIs+ )+ xpRobots+ xpickle+ xpickle+ )+ where+ xpURIs = xpWrap ( fromListURIs, toListURIs ) $+ xpList $+ xpElem "doc" $+ xpAttr "href" $+ xpText+ xpURIsWithLevel = xpWrap ( fromListURIs', toListURIs' ) $+ xpList $+ xpElem "doc" $+ xpPair ( xpAttr "href" $+ xpText+ )+ ( xpAttr "clicklevel"+ xpInt+ )++-- ------------------------------------------------------------++-- | selector functions for CrawlerState++theToBeProcessed :: Selector (CrawlerState r) URIsWithLevel+theToBeProcessed = S cs_toBeProcessed (\ x s -> s {cs_toBeProcessed = x})++theAlreadyProcessed :: Selector (CrawlerState r) URIs+theAlreadyProcessed = S cs_alreadyProcessed (\ x s -> s {cs_alreadyProcessed = x})++theRobots :: Selector (CrawlerState r) Robots+theRobots = S cs_robots (\ x s -> s {cs_robots = x})++theNoOfDocs :: Selector (CrawlerState r) Int+theNoOfDocs = S cs_noOfDocs (\ x s -> s {cs_noOfDocs = x})++theNoOfDocsSaved :: Selector (CrawlerState r) Int+theNoOfDocsSaved = S cs_noOfDocsSaved (\ x s -> s {cs_noOfDocsSaved = x})++theListOfDocsSaved :: Selector (CrawlerState r) [Int]+theListOfDocsSaved = S cs_listOfDocsSaved (\ x s -> s {cs_listOfDocsSaved = x})++theResultAccu :: Selector (CrawlerState r) r+theResultAccu = S cs_resultAccu (\ x s -> s {cs_resultAccu = x})++theResultInit :: Selector (CrawlerState r) r+theResultInit = S cs_resultInit (\ x s -> s {cs_resultInit = x})++-- | selector functions for CrawlerConfig++theSysConfig :: Selector (CrawlerConfig a r) SysConfig+theSysConfig = S cc_sysConfig (\ x s -> s {cc_sysConfig = x})++theTraceLevel :: Selector (CrawlerConfig a r) Priority+theTraceLevel = S cc_traceLevel (\ x s -> s {cc_traceLevel = x})++theTraceLevelHxt :: Selector (CrawlerConfig a r) Priority+theTraceLevelHxt = S cc_traceLevelHxt (\ x s -> s {cc_traceLevelHxt = x})++theClickLevel :: Selector (CrawlerConfig a r) Int+theClickLevel = S cc_clickLevel (\ x s -> s {cc_clickLevel = x})++theMaxNoOfDocs :: Selector (CrawlerConfig a r) Int+theMaxNoOfDocs = S cc_maxNoOfDocs (\ x s -> s {cc_maxNoOfDocs = x})++theMaxParDocs :: Selector (CrawlerConfig a r) Int+theMaxParDocs = S cc_maxParDocs (\ x s -> s {cc_maxParDocs = x})++theMaxParThreads :: Selector (CrawlerConfig a r) Int+theMaxParThreads = S cc_maxParThreads (\ x s -> s {cc_maxParThreads = x})++theSaveIntervall :: Selector (CrawlerConfig a r) Int+theSaveIntervall = S cc_saveIntervall (\ x s -> s {cc_saveIntervall = x})++theSavePathPrefix :: Selector (CrawlerConfig a r) String+theSavePathPrefix = S cc_savePathPrefix (\ x s -> s {cc_savePathPrefix = x})++theSavePreAction :: Selector (CrawlerConfig a r) (FilePath -> CrawlerAction a r ()) -- (SavePartialResults r)+theSavePreAction = S cc_savePreAction (\ x s -> s {cc_savePreAction = x})++theFollowRef :: Selector (CrawlerConfig a r) (URI -> Bool)+theFollowRef = S cc_followRef (\ x s -> s {cc_followRef = x})++theAddRobotsAction :: Selector (CrawlerConfig a r) (CrawlerConfig a r -> AddRobotsAction)+theAddRobotsAction = S cc_addRobotsTxt (\ x s -> s {cc_addRobotsTxt = x})++theAccumulateOp :: Selector (CrawlerConfig a r) (AccumulateDocResult a r)+theAccumulateOp = S cc_accumulate (\ x s -> s {cc_accumulate = x})++theFoldOp :: Selector (CrawlerConfig a r) (MergeDocResults r)+theFoldOp = S cc_fold (\ x s -> s {cc_fold = x})++thePreRefsFilter :: Selector (CrawlerConfig a r) (IOSArrow XmlTree XmlTree)+thePreRefsFilter = S cc_preRefsFilter (\ x s -> s {cc_preRefsFilter = x})++theProcessRefs :: Selector (CrawlerConfig a r) (IOSArrow XmlTree URI)+theProcessRefs = S cc_processRefs (\ x s -> s {cc_processRefs = x})++thePreDocFilter :: Selector (CrawlerConfig a r) (IOSArrow XmlTree XmlTree)+thePreDocFilter = S cc_preDocFilter (\ x s -> s {cc_preDocFilter = x})++theProcessDoc :: Selector (CrawlerConfig a r) (IOSArrow XmlTree a)+theProcessDoc = S cc_processDoc (\ x s -> s {cc_processDoc = x})++-- ------------------------------------------------------------++-- a rather boring default crawler configuration++defaultCrawlerConfig :: AccumulateDocResult a r -> MergeDocResults r -> CrawlerConfig a r+defaultCrawlerConfig op op2+ = CrawlerConfig+ { cc_sysConfig = ( withCurl [ (curl_user_agent, defaultCrawlerName)+ , (curl_max_time, show $ (60 * 1000::Int)) -- whole transaction for reading a document must complete within 60,000 milli seconds, + , (curl_connect_timeout, show $ (10::Int)) -- connection must be established within 10 seconds+ ]+ )+ , cc_preRefsFilter = this -- no preprocessing for refs extraction+ , cc_processRefs = none -- don't extract refs+ , cc_preDocFilter = checkDocumentStatus -- default: in case of errors throw away any contents+ , cc_processDoc = none -- no document processing at all+ , cc_accumulate = op -- combining function for result accumulating+ , cc_fold = op2+ , cc_followRef = const False -- do not follow any refs+ , cc_addRobotsTxt = const $ const return -- do not add robots.txt evaluation+ , cc_saveIntervall = (-1) -- never save an itermediate state+ , cc_savePathPrefix = "/tmp/hc-" -- the prefix for filenames into which intermediate states are saved+ , cc_savePreAction = const $ return () -- no action before saving state+ , cc_clickLevel = maxBound -- click level set to infinity+ , cc_maxNoOfDocs = (-1) -- maximum # of docs to be crawled, -1 means unlimited+ , cc_maxParDocs = 20 -- maximum # of doc crawled in parallel+ , cc_maxParThreads = 5 -- maximum # of threads running in parallel+ , cc_traceLevel = NOTICE -- traceLevel+ , cc_traceLevelHxt = WARNING -- traceLevel for hxt+ }++theInputOptions :: Selector (CrawlerConfig a r) Attributes+theInputOptions = theSysConfig+ >>>+ HXT.theSysConfigComp HXT.theInputOptions++theCrawlerName :: Selector (CrawlerConfig a r) String+theCrawlerName = theInputOptions+ >>>+ S { getS = lookupDef defaultCrawlerName curl_user_agent+ , setS = addEntry curl_user_agent+ }++theMaxTime :: Selector (CrawlerConfig a r) Int+theMaxTime = theInputOptions+ >>>+ S { getS = read . lookupDef "0" curl_max_time+ , setS = addEntry curl_max_time . show . (`max` 1)+ }++theConnectTimeout :: Selector (CrawlerConfig a r) Int+theConnectTimeout = theInputOptions+ >>>+ S { getS = read . lookupDef "0" curl_connect_timeout+ , setS = addEntry curl_connect_timeout . show . (`max` 1)+ }+++-- ------------------------------------------------------------++-- | Add attributes for accessing documents++addSysConfig :: SysConfig -> CrawlerConfig a r -> CrawlerConfig a r+addSysConfig cf = chgS theSysConfig ( >>> cf )++-- | Insert a robots no follow filter before thePreRefsFilter++addRobotsNoFollow :: CrawlerConfig a r -> CrawlerConfig a r+addRobotsNoFollow = chgS thePreRefsFilter ( robotsNoFollow >>> )++-- | Insert a robots no follow filter before thePreRefsFilter++addRobotsNoIndex :: CrawlerConfig a r -> CrawlerConfig a r+addRobotsNoIndex = chgS thePreDocFilter ( robotsNoIndex >>> )+++-- | Set the log level++setCrawlerTraceLevel :: Priority -> Priority -> CrawlerConfig a r -> CrawlerConfig a r+setCrawlerTraceLevel l lx+ = setS theTraceLevel l+ >>>+ setS theTraceLevelHxt lx++-- | Set save intervall in config++setCrawlerSaveConf :: Int -> String -> CrawlerConfig a r -> CrawlerConfig a r+setCrawlerSaveConf i f = setS theSaveIntervall i+ >>>+ setS theSavePathPrefix f++-- | Set action performed before saving crawler state++setCrawlerSaveAction :: (FilePath -> CrawlerAction a r ()) -> CrawlerConfig a r -> CrawlerConfig a r+setCrawlerSaveAction f = setS theSavePreAction f++-- | Set max # of steps (clicks) to reach a document++setCrawlerClickLevel :: Int -> CrawlerConfig a r -> CrawlerConfig a r+setCrawlerClickLevel mcl+ = setS theClickLevel mcl++-- | Set max # of documents to be crawled+-- and max # of documents crawled in parallel++setCrawlerMaxDocs :: Int -> Int -> Int -> CrawlerConfig a r -> CrawlerConfig a r+setCrawlerMaxDocs mxd mxp mxt+ = setS theMaxNoOfDocs mxd+ >>>+ setS theMaxParDocs mxp+ >>>+ setS theMaxParThreads mxt++-- | Set the pre hook filter executed before the hrefs are collected++setCrawlerPreRefsFilter :: IOSArrow XmlTree XmlTree -> CrawlerConfig a r -> CrawlerConfig a r+setCrawlerPreRefsFilter f+ = setS thePreRefsFilter f++-- ------------------------------------------------------------++instance (Binary r) => Binary (CrawlerState r) where+ put s = do+ B.put (getS theToBeProcessed s)+ B.put (getS theAlreadyProcessed s)+ B.put (getS theRobots s)+ B.put (getS theNoOfDocs s)+ B.put (getS theNoOfDocsSaved s)+ B.put (getS theListOfDocsSaved s)+ B.put (getS theResultAccu s)+ B.put (getS theResultInit s)+ get = do+ tbp <- B.get+ alp <- B.get+ rbt <- B.get+ mxd <- B.get+ mxs <- B.get+ lsd <- B.get+ acc <- B.get+ ini <- B.get+ return $ CrawlerState+ { cs_toBeProcessed = tbp+ , cs_alreadyProcessed = alp+ , cs_robots = rbt+ , cs_noOfDocs = mxd+ , cs_noOfDocsSaved = mxs+ , cs_listOfDocsSaved = lsd+ , cs_resultAccu = acc+ , cs_resultInit = ini+ }++putCrawlerState :: (Binary r) => CrawlerState r -> B.Put+putCrawlerState = B.put++getCrawlerState :: (Binary r) => B.Get (CrawlerState r)+getCrawlerState = B.get++initCrawlerState :: r -> CrawlerState r+initCrawlerState r = CrawlerState+ { cs_toBeProcessed = emptyURIs+ , cs_alreadyProcessed = emptyURIs+ , cs_robots = emptyRobots+ , cs_noOfDocs = 0+ , cs_noOfDocsSaved = 0+ , cs_listOfDocsSaved = []+ , cs_resultAccu = r+ , cs_resultInit = r+ }++-- ------------------------------------------------------------+--+-- basic crawler actions++-- | Load a component from the crawler configuration++getConf :: Selector (CrawlerConfig a r) v -> CrawlerAction a r v+getConf = asks . getS++getState :: Selector (CrawlerState r) v -> CrawlerAction a r v+getState = gets . getS++putState :: Selector (CrawlerState r) v -> v -> CrawlerAction a r ()+putState sel = modify . setS sel++modifyState :: Selector (CrawlerState r) v -> (v -> v) -> CrawlerAction a r ()+modifyState sel = modify . chgS sel++modifyStateIO :: Selector (CrawlerState r) v -> (v -> IO v) -> CrawlerAction a r ()+modifyStateIO sel = modifyIO . chgM sel++-- ------------------------------------------------------------+
+ src/Holumbus/Crawler/URIs.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.URIs+where++import qualified Holumbus.Data.PrefixTree as S++-- ------------------------------------------------------------++-- | An URI is represented as a String+type URI = String+type URIWithLevel = (URI, Int)++-- | A set of URIs implemeted as a prefix tree. This implementation+-- is space efficient, because of many equal prefixes in the crawled set of URIs++type URIs = URIs' ()+type URIsWithLevel = URIs' Int -- URIs with a priority or clicklevel++type URIs' a = S.PrefixTree a++-- ------------------------------------------------------------++emptyURIs :: URIs' a+emptyURIs = S.empty++singletonURIs :: URI -> URIs+singletonURIs = flip S.singleton ()++singletonURIs' :: URI -> a -> URIs' a+singletonURIs' = S.singleton++nullURIs :: URIs' a -> Bool+nullURIs = S.null++memberURIs :: URI -> URIs' a -> Bool+memberURIs = S.member++cardURIs :: URIs' a -> Int+cardURIs = S.size++nextURI :: URIs' a -> (URI, a)+nextURI = head . toListURIs'++nextURIs :: Int -> URIs' a -> [(URI, a)]+nextURIs n = take n . toListURIs'++insertURI :: URI -> URIs -> URIs+insertURI = flip S.insert ()++insertURI' :: URI -> a -> URIs' a -> URIs' a+insertURI' = S.insert++deleteURI :: URI -> URIs' a -> URIs' a+deleteURI = S.delete++deleteURIs :: URIs' b -> URIs' a -> URIs' a+deleteURIs = flip S.difference++unionURIs :: URIs -> URIs -> URIs+unionURIs = S.union++unionURIs' :: (a -> a -> a) -> URIs' a -> URIs' a -> URIs' a+unionURIs' = S.unionWith++diffURIs :: URIs' a -> URIs' a -> URIs' a+diffURIs = S.difference++fromListURIs :: [URI] -> URIs+fromListURIs = S.fromList . map (\ x -> (x, ()))++fromListURIs' :: [(URI, a)] -> URIs' a+fromListURIs' = S.fromList++toListURIs :: URIs' a -> [URI]+toListURIs = S.keys -- map fst . S.toList++toListURIs' :: URIs' a -> [(URI, a)]+toListURIs' = S.toList++foldURIs :: (URI -> b -> b) -> b -> URIs -> b+foldURIs f = S.foldWithKey (\ x _ r -> f x r)++foldURIs' :: (URI -> a -> b -> b) -> b -> URIs' a -> b+foldURIs' = S.foldWithKey++-- ------------------------------------------------------------++
+ src/Holumbus/Crawler/Util.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.Util+where++import Control.Applicative ( liftA2 )++import Data.List++import qualified Text.Regex.XMLSchema.String as RE++-- ------------------------------------------------------------++-- | create temp file name++mkTmpFile :: Int -> String -> Int -> String+mkTmpFile n s i = (s ++) . reverse . take n . (++ replicate n '0') . reverse . show $ i++-- ------------------------------------------------------------++-- | Simple predicate genertor for filtering of URIs+-- If the first predicate (isAllowed) holds and the second (isDenied) does not hold+-- the predicate holds. This can be used for constructing simple URL filters++simpleFollowRef :: (String -> Bool) -> (String -> Bool) -> (String -> Bool)+simpleFollowRef isAllowed isDenied+ = isAllowed .&&. (not . isDenied)+ where+ (.&&.) = liftA2 (&&)++-- | A convenient function, that takes two lists of strings in regexp syntax,+-- The first list are the patterns for the allowed strings,+-- the second one for the patterns to deny the string.+-- Two regular expressions are build from these lists of strings,+-- and the string to be tested is matched against both regexes++simpleFollowRef' :: [String] -> [String] -> (String -> Bool)+simpleFollowRef' allowed denied+ = simpleFollowRef allowed' denied'+ where+ mkAlt :: [String] -> String+ mkAlt rs = "(" ++ intercalate "|" rs ++ ")"+ allowed'+ | null allowed = const True+ | otherwise = match $ mkAlt allowed+ denied'+ | null denied = const False+ | otherwise = match $ mkAlt denied++-- ------------------------------------------------------------++match :: String -> String -> Bool+match re = RE.matchRE (parseRE re)++sed :: (String -> String) -> String -> String -> String+sed edit re = parseRE re `seq` RE.sed edit re++split :: String -> String -> (String, String)+split re = parseRE re `seq` RE.split re++tokenize :: String -> String -> [String]+tokenize re = parseRE re `seq` RE.tokenize re++-- ------------------------------------------------------------++parseRE :: String -> RE.Regex+parseRE re = check . RE.parseRegex $ re+ where+ check re'+ | RE.isZero re' = error $ "\nsyntax error in regexp: " ++ re ++ "\n" ++ RE.errRegex re'+ | otherwise = re'++-- ------------------------------------------------------------
+ src/Holumbus/Crawler/XmlArrows.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Crawler.XmlArrows+where++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | Remove contents, when document status isn't ok, but remain meta info++checkDocumentStatus :: IOSArrow XmlTree XmlTree+checkDocumentStatus = replaceChildren none+ `whenNot`+ documentStatusOk++-- ------------------------------------------------------------+
+ src/Holumbus/Data/Crunch.hs view
@@ -0,0 +1,160 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Data.Crunch+ Copyright : Copyright (C) 2008 Timo B. Huebel+ License : MIT+ + Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.1+ + This module provides compression for streams of 32-bit words. Because of + some internal restriction in GHC, which makes all fixed integer size equal+ in terms of bit-width, the algorithm tries to crunch as much numbers as+ possible into a single 64-bit word.++ Based on the Simple9 encoding scheme from this article:+ + * Vo N. Anh, Alstair Moffat,+ \"/Inverted Index Compression Using Word-Aligned Binary Codes/\",+ Information Retrieval, 8 (1), 2005, pages 151-166++-}++-- ----------------------------------------------------------------------------++{-# OPTIONS -fno-warn-type-defaults #-}++module Holumbus.Data.Crunch + (+ -- * Compression+ crunch8+ , crunch16+ , crunch32+ , crunch64+ + -- * Decompression+ , decrunch8+ , decrunch16+ , decrunch32+ , decrunch64+ )+where++import Data.Bits+import Data.Word++data Width = W01 | W02 | W03 | W04 | W05 | W06 | W07 | W08 | W10 | W12 | W15 | W20 | W30 | W60+ deriving (Show, Eq, Enum)++-- | Increase performance by avoiding the calculation of maximum values.+value :: Width -> Word64+value W01 = (2 ^ 1) - 1+value W02 = (2 ^ 2) - 1+value W03 = (2 ^ 3) - 1+value W04 = (2 ^ 4) - 1+value W05 = (2 ^ 5) - 1+value W06 = (2 ^ 6) - 1+value W07 = (2 ^ 7) - 1+value W08 = (2 ^ 8) - 1+value W10 = (2 ^ 10) - 1+value W12 = (2 ^ 12) - 1+value W15 = (2 ^ 15) - 1+value W20 = (2 ^ 20) - 1+value W30 = (2 ^ 30) - 1+value W60 = (2 ^ 60) - 1++-- | Increase performance by avoiding the calculation of counts.+count :: Width -> Int+count W01 = 60+count W02 = 30+count W03 = 20+count W04 = 15+count W05 = 12+count W06 = 10+count W07 = 8+count W08 = 7+count W10 = 6+count W12 = 5+count W15 = 4+count W20 = 3+count W30 = 2+count W60 = 1++width :: Width -> Int+width W01 = 1+width W02 = 2+width W03 = 3+width W04 = 4+width W05 = 5+width W06 = 6+width W07 = 7+width W08 = 8+width W10 = 10+width W12 = 12+width W15 = 15+width W20 = 20+width W30 = 30+width W60 = 60++-- | Crunch some values by encoding several values into one 'Word64'. The values may not exceed+-- the upper limit of @(2 ^ 60) - 1@. This precondition is not checked! The compression works+-- best on small values, therefore a difference encoding (like the one in +-- "Holumbus.Data.DiffList") prior to compression pays off well.+crunch64 :: [Word64] -> [Word64]+crunch64 [] = []+crunch64 s = crunch' s (count W01) W01 []++-- | Crunch a non empty list. This precondition is not checked!+crunch' :: [Word64] -> Int -> Width -> [Word64] -> [Word64]+crunch' [] 0 m r = [encode m r]+crunch' [] _ m r = crunch' r (count (succ m)) (succ m) []+crunch' s 0 m r = (encode m r):(crunch' s (count W01) W01 [])+crunch' s@(x:xs) n m r = if x <= value m then crunch' xs (n - 1) m (r ++ [x])+ else crunch' (r ++ s) (count (succ m)) (succ m) []++-- | Encode some numbers with a given width. The number of elements in the list may not exceed +-- the amount of numbers allowed for this width and the numbers in the list may not exceed the+-- upper bound for this width. These preconditions are not checked!+encode :: Width -> [Word64] -> Word64 +encode w [] = rotateR (fromIntegral (fromEnum w)) (64 - (width w * count w))+encode w (x:xs) = rotateR (encode w xs .|. fromIntegral x) (width w)++-- | Decrunch a list of crunched values. No checking for properly encoded values is done, weird+-- results have to be expected if calling this function on a list of arbitrary values.+decrunch64 :: [Word64] -> [Word64]+decrunch64 [] = []+decrunch64 (x:xs) = (decode (width w) (count w) (value w) (rotateL x (width w))) ++ (decrunch64 xs)+ where+ w = toEnum $ fromIntegral (x .&. 15) -- Extract the 4 selector bits.++-- Decode some numbers with a given width.+decode :: Int -> Int -> Word64 -> Word64 -> [Word64]+decode _ 0 _ _ = []+decode w n m x = (x .&. m):(decode w (n - 1) m (rotateL x w))++-- | Crunching 'Word8' values, defined in terms of 'crunch64'.+crunch8 :: [Word8] -> [Word64]+crunch8 = crunch64 . (map fromIntegral)++-- | Crunching 'Word16' values, defined in terms of 'crunch64'.+crunch16 :: [Word16] -> [Word64]+crunch16 = crunch64 . (map fromIntegral)++-- | Crunching 'Word32' values, defined in terms of 'crunch64'.+crunch32 :: [Word32] -> [Word64]+crunch32 = crunch64 . (map fromIntegral)++-- | Decrunching to 'Word8' values, defined in terms of 'decrunch64'.+decrunch8 :: [Word64] -> [Word8]+decrunch8 = (map fromIntegral) . decrunch64++-- | Decrunching to 'Word16' values, defined in terms of 'decrunch64'.+decrunch16 :: [Word64] -> [Word16]+decrunch16 = (map fromIntegral) . decrunch64++-- | Decrunching to 'Word32' values, defined in terms of 'decrunch64'.+decrunch32 :: [Word64] -> [Word32]+decrunch32 = (map fromIntegral) . decrunch64
+ src/Holumbus/Data/PrefixTree.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Data.PrefixTree+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ Facade for prefix tree implementation+ +-}++-- ----------------------------------------------------------------------------++module Holumbus.Data.PrefixTree+ ( PrefixTree (..)+ , Key+ , (!)+ , value+ , valueWithDefault+ , null+ , size+ , member+ , lookup+ , findWithDefault + , prefixFind+ , prefixFindWithKey+ , prefixFindWithKeyBF+ , empty+ , singleton+ , insert+ , insertWith+ , insertWithKey+ , delete+ , update+ , updateWithKey+ , map+ , mapWithKey+ , mapM+ , mapWithKeyM+ , fold+ , foldWithKey+ , union+ , unionWith+ , unionWithKey+ , difference+ , differenceWith+ , differenceWithKey+ , keys+ , elems+ , toList+ , fromList+ , toListBF+ , toMap+ , fromMap+ , space+ , keyChars++ , prefixFindCaseWithKey -- fuzzy search+ , prefixFindNoCaseWithKey+ , prefixFindNoCase+ , lookupNoCase++ , prefixFindCaseWithKeyBF+ , prefixFindNoCaseWithKeyBF+ , lookupNoCaseBF+ )+where++import Prelude hiding ( succ, lookup, map, mapM, null )++import Holumbus.Data.PrefixTree.Core+import Holumbus.Data.PrefixTree.FuzzySearch+import Holumbus.Data.PrefixTree.Types
+ src/Holumbus/Data/PrefixTree/Core.hs view
@@ -0,0 +1,942 @@+{-# OPTIONS -XBangPatterns #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Data.PrefixTree.Core+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ An efficient implementation of maps from strings to arbitrary values.++ Values can associated with an arbitrary byte key. Searching for keys is very fast, but+ the prefix tree probably consumes more memory than "Data.Map". The main differences are the special+ 'prefixFind' functions, which can be used to perform prefix queries. The interface is+ heavily borrowed from "Data.Map" and "Data.IntMap".++ Most other function names clash with "Prelude" names, therefore this module is usually+ imported @qualified@, e.g.+ + > import Holumbus.Data.PrefixTree (PrefixTree)+ > import qualified Holumbus.Data.PrefixTree as T++ Many functions have a worst-case complexity of /O(min(n,L))/. This means that the operation+ can become linear with the number of elements with a maximum of /L/, the length of the+ key (the number of bytes in the list). The functions for searching a prefix have a worst-case+ complexity of /O(max(L,R))/. This means that the operation can become linear with+ /R/, the number of elements found for the prefix, with a minimum of /L/.+ + The module exports include the internal data types, their constructors and access+ functions for ultimate flexibility. Derived modules should not export these + (as shown in "Holumbus.Data.StrMap") to provide only a restricted interface.+ +-}++-- ----------------------------------------------------------------------------++module Holumbus.Data.PrefixTree.Core+where++import Prelude hiding ( succ, lookup, map, mapM, null )++import Control.Arrow+import Control.DeepSeq++import qualified Data.Foldable++import Data.Binary+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe++import Holumbus.Data.PrefixTree.Types+import Holumbus.Data.PrefixTree.PrefixSet++data PrefixTree v = Empty+ | Val { value' :: v+ , tree :: ! (PrefixTree v)+ }+ | Branch { sym :: {-# UNPACK #-}+ ! Sym+ , child :: ! (PrefixTree v)+ , next :: ! (PrefixTree v)+ }++ -- the space optimisation nodes, these+ -- will be normalized during access into+ -- the three constructors Empty, Val and Branch++ | Leaf { value' :: v -- a value at a leaf of the tree+ }+ | Last { sym :: {-# UNPACK #-}+ ! Sym -- the last entry in a branch list+ , child :: ! (PrefixTree v) -- or no branch but a single child+ }+ | LsSeq { syms :: ! Key1 -- a sequence of single childs+ , child :: ! (PrefixTree v) -- in a last node+ } + | BrSeq { syms :: ! Key1 -- a sequence of single childs+ , child :: ! (PrefixTree v) -- in a branch node+ , next :: ! (PrefixTree v)+ } + | LsSeL { syms :: ! Key1 -- a sequence of single childs+ , value' :: v -- with a leaf + } + | BrSeL { syms :: ! Key1 -- a sequence of single childs+ , value' :: v -- with a leaf in a branch node+ , next :: ! (PrefixTree v)+ } + | BrVal { sym :: {-# UNPACK #-}+ ! Sym -- a branch with a single char+ , value' :: v -- and a value+ , next :: ! (PrefixTree v)+ }+ | LsVal { sym :: {-# UNPACK #-}+ ! Sym -- a last node with a single char+ , value' :: v -- and a value+ }+ deriving (Show, Eq, Ord)++-- | strict list of chars with unpacked fields+--+-- for internal use in prefix tree to optimize space efficiency++data Key1 = Nil+ | Cons {-# UNPACK #-}+ ! Sym+ ! Key1 + deriving (Show, Eq, Ord)++(.++.) :: Key1 -> Key1 -> Key1+Nil .++. k2 = k2+(Cons k k1) .++. k2 = Cons k (k1 .++. k2)++toKey :: Key1 -> Key+toKey Nil = []+toKey (Cons c k1) = c : toKey k1++fromKey :: Key -> Key1+fromKey [] = Nil+fromKey (c:k1) = Cons c (fromKey k1)++length1 :: Key1 -> Int+length1 = length . toKey++-- ----------------------------------------++-- smart constructors++empty :: PrefixTree v+empty = Empty++{-# INLINE empty #-}++val :: v -> PrefixTree v -> PrefixTree v+val v Empty = Leaf v+val v t = Val v t++{-# INLINE val #-}++branch :: Sym -> PrefixTree v -> PrefixTree v -> PrefixTree v+branch !_k Empty n = n++branch !k (Leaf v ) Empty = LsVal k v+branch !k (LsVal k1 v) Empty = LsSeL (Cons k (Cons k1 Nil)) v+branch !k (LsSeL ks v) Empty = LsSeL (Cons k ks) v+branch !k (Last k1 c) Empty = lsseq (Cons k (Cons k1 Nil)) c+branch !k (LsSeq ks c) Empty = lsseq (Cons k ks) c+branch !k c Empty = Last k c++branch !k (Leaf v ) n = BrVal k v n+branch !k (LsVal k1 v) n = BrSeL (Cons k (Cons k1 Nil)) v n+branch !k (LsSeL ks v) n = BrSeL (Cons k ks) v n+branch !k (Last k1 c) n = brseq (Cons k (Cons k1 Nil)) c n+branch !k (LsSeq ks c) n = brseq (Cons k ks) c n+branch !k c n = Branch k c n++lsseq :: Key1 -> PrefixTree v -> PrefixTree v+lsseq !k (Leaf v) = LsSeL k v+lsseq !k c = LsSeq k c++{-# INLINE lsseq #-}++brseq :: Key1 -> PrefixTree v -> PrefixTree v -> PrefixTree v+brseq !k (Leaf v) n = BrSeL k v n+brseq !k c n = BrSeq k c n++{-# INLINE brseq #-}++siseq :: Key1 -> PrefixTree v -> PrefixTree v+siseq Nil c = c+siseq (Cons k1 Nil) c = Last k1 c+siseq k c = LsSeq k c++{-# INLINE siseq #-}++-- smart selectors++norm :: PrefixTree v -> PrefixTree v+norm (Leaf v) = Val v empty+norm (Last k c) = Branch k c empty+norm (LsSeq (Cons k Nil) c) = Branch k c empty+norm (LsSeq (Cons k ks ) c) = Branch k (siseq ks c) empty +norm (BrSeq (Cons k Nil) c n) = Branch k c n+norm (BrSeq (Cons k ks ) c n) = Branch k (siseq ks c) n +norm (LsSeL ks v) = norm (LsSeq ks (val v empty))+norm (BrSeL ks v n) = norm (BrSeq ks (val v empty) n)+norm (LsVal k v) = norm (LsSeq (Cons k Nil) (val v empty))+norm (BrVal k v n) = norm (BrSeq (Cons k Nil) (val v empty) n)+norm t = t++-- ----------------------------------------++deepNorm :: PrefixTree v -> PrefixTree v+deepNorm t0+ = case norm t0 of+ Empty -> Empty+ Val v t -> Val v (deepNorm t)+ Branch c s n -> Branch c (deepNorm s) (deepNorm n)+ _ -> normError "deepNorm"++-- ----------------------------------------++normError :: String -> a+normError f = error (f ++ ": pattern match error, prefix tree not normalized")++-- ----------------------------------------++-- | /O(1)/ Is the map empty?++null :: PrefixTree a -> Bool+null Empty = True+null _ = False++{-# INLINE null #-}++-- | /O(1)/ Create a map with a single element.++singleton :: Key -> a -> PrefixTree a+singleton k v = foldr (\ c r -> branch c r empty) (val v empty) $ k -- siseq k (val v empty)++{-# INLINE singleton #-}++-- | /O(1)/ Extract the value of a node (if there is one)++value :: Monad m => PrefixTree a -> m a+value t = case norm t of+ Val v _ -> return v+ _ -> fail "PrefixTree.value: no value at this node"++{-# INLINE value #-}++-- | /O(1)/ Extract the value of a node or return a default value if no value exists.++valueWithDefault :: a -> PrefixTree a -> a+valueWithDefault d t = fromMaybe d . value $ t+++-- | /O(1)/ Extract the successors of a node++succ :: PrefixTree a -> PrefixTree a+succ t = case norm t of+ Val _ t' -> succ t'+ t' -> t'+{-# INLINE succ #-}++-- ----------------------------------------++-- | /O(min(n,L))/ Find the value associated with a key. The function will @return@ the result in+-- the monad or @fail@ in it if the key isn't in the map.++lookup :: Monad m => Key -> PrefixTree a -> m a+lookup k t = case lookup' k t of+ Just v -> return v+ Nothing -> fail "PrefixTree.lookup: Key not found"+{-# INLINE lookup #-}++-- | /O(min(n,L))/ Find the value associated with a key. The function will @return@ the result in+-- the monad or @fail@ in it if the key isn't in the map.++findWithDefault :: a -> Key -> PrefixTree a -> a+findWithDefault v0 k = fromMaybe v0 . lookup' k++{-# INLINE findWithDefault #-}++-- | /O(min(n,L))/ Is the key a member of the map?++member :: Key -> PrefixTree a -> Bool+member k = maybe False (const True) . lookup k++{-# INLINE member #-}++-- | /O(min(n,L))/ Find the value at a key. Calls error when the element can not be found.++(!) :: PrefixTree a -> Key -> a+(!) = flip $ findWithDefault (error "PrefixTree.! : element not in the map")++-- | /O(min(n,L))/ Insert a new key and value into the map. If the key is already present in+-- the map, the associated value will be replaced with the new value.++insert :: Key -> a -> PrefixTree a -> PrefixTree a+insert = insertWith const++{-# INLINE insert #-}++-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map,+-- the value of @f new_value old_value@ will be inserted.++insertWith :: (a -> a -> a) -> Key -> a -> PrefixTree a -> PrefixTree a+insertWith f = flip $ insert' f++{-# INLINE insertWith #-}++-- | /O(min(n,L))/ Insert with a combining function. If the key is already present in the map,+-- the value of @f key new_value old_value@ will be inserted.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> PrefixTree a -> PrefixTree a+insertWithKey f k = insertWith (f k) k+++{-# INLINE insertWithKey #-}++-- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- element if the result of the updating function is 'Nothing'. If the key is not found, the trie+-- is returned unchanged.++update :: (a -> Maybe a) -> Key -> PrefixTree a -> PrefixTree a+update = update'++{-# INLINE update #-}++-- | /O(min(n,L))/ Updates a value at a given key (if that key is in the trie) or deletes the +-- element if the result of the updating function is 'Nothing'. If the key is not found, the trie+-- is returned unchanged.++updateWithKey :: (Key -> a -> Maybe a) -> Key -> PrefixTree a -> PrefixTree a+updateWithKey f k = update' (f k) k++{-# INLINE updateWithKey #-}++-- | /O(min(n,L))/ Delete an element from the map. If no element exists for the key, the map +-- remains unchanged.++delete :: Key -> PrefixTree a -> PrefixTree a+delete = update' (const Nothing)++{-# INLINE delete #-}++-- ----------------------------------------++lookupPx' :: Key -> PrefixTree a -> PrefixTree a+lookupPx' k0 = look k0 . norm+ where+ look [] t = t+ look k@(c : k1) (Branch c' s' n')+ | c < c' = empty+ | c == c' = lookupPx' k1 s'+ | otherwise = lookupPx' k n'+ look _ Empty = empty+ look k (Val _v' t') = lookupPx' k t'++ look _ _ = normError "lookupPx'"++-- Internal lookup function which is generalised for arbitrary monads above.++lookup' :: Key -> PrefixTree a -> Maybe a+lookup' k t+ = case lookupPx' k t of+ Val v _ -> Just v+ _ -> Nothing++-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key.++prefixFind :: Key -> PrefixTree a -> [a] +prefixFind k = elems . lookupPx' k++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key and include the keys +-- in the result.++prefixFindWithKey :: Key -> PrefixTree a -> [(Key, a)]+prefixFindWithKey k = fmap (first (k ++)) . toList . lookupPx' k++-- ----------------------------------------++insert' :: (a -> a -> a) -> a -> Key -> PrefixTree a -> PrefixTree a+insert' f v k0 = ins k0 . norm+ where+ ins' = insert' f v++ ins k (Branch c' s' n')+ = case k of+ [] -> val v (branch c' s' n')+ (c : k1)+ | c < c' -> branch c (singleton k1 v) (branch c' s' n')+ | c == c' -> branch c (ins' k1 s') n'+ | otherwise -> branch c' s' (ins' k n')++ ins k Empty = singleton k v++ ins k (Val v' t')+ = case k of+ [] -> val (f v v') t'+ _ -> val v' (ins' k t')++ ins _ _ = normError "insert'"++-- ----------------------------------------++update' :: (a -> Maybe a) -> Key -> PrefixTree a -> PrefixTree a+update' f k0 = upd k0 . norm+ where+ upd' = update' f++ upd k (Branch c' s' n')+ = case k of+ [] -> branch c' s' n'+ (c : k1)+ | c < c' -> branch c' s' n'+ | c == c' -> branch c (upd' k1 s') n'+ | otherwise -> branch c' s' (upd' k n')++ upd _ Empty = empty++ upd k (Val v' t')+ = case k of+ [] -> maybe t' (flip val t') $ f v'+ _ -> val v' (upd' k t')+ upd _ _ = normError "update'"++-- ----------------------------------------++-- | /O(n+m)/ Left-biased union of two maps. It prefers the first map when duplicate keys are +-- encountered, i.e. ('union' == 'unionWith' 'const').++union :: PrefixTree a -> PrefixTree a -> PrefixTree a+union = union' const++-- | /O(n+m)/ Union with a combining function.++unionWith :: (a -> a -> a) -> PrefixTree a -> PrefixTree a -> PrefixTree a+unionWith = union'++union' :: (a -> a -> a) -> PrefixTree a -> PrefixTree a -> PrefixTree a+union' f pt1 pt2 = uni (norm pt1) (norm pt2)+ where+ uni' t1' t2' = union' f (norm t1') (norm t2')++ uni Empty Empty = empty+ uni Empty (Val v2 t2) = val v2 t2+ uni Empty (Branch c2 s2 n2)+ = branch c2 s2 n2++ uni (Val v1 t1) Empty = val v1 t1+ uni (Val v1 t1) (Val v2 t2) = val (f v1 v2) (uni' t1 t2)+ uni (Val v1 t1) t2@(Branch _ _ _) = val v1 (uni' t1 t2)++ uni (Branch c1 s1 n1) Empty = branch c1 s1 n1+ uni t1@(Branch _ _ _ ) (Val v2 t2) = val v2 (uni' t1 t2) + uni t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = branch c1 s1 (uni' n1 t2)+ | c1 > c2 = branch c2 s2 (uni' t1 n2)+ | otherwise = branch c1 (uni' s1 s2) (uni' n1 n2)+ uni _ _ = normError "union'"++-- ----------------------------------------++-- | /O(n+m)/ Union with a combining function, including the key.++unionWithKey :: (Key -> a -> a -> a) -> PrefixTree a -> PrefixTree a -> PrefixTree a+unionWithKey f = union'' f id++union'' :: (Key -> a -> a -> a) -> (Key -> Key) -> PrefixTree a -> PrefixTree a -> PrefixTree a+union'' f kf pt1 pt2 = uni (norm pt1) (norm pt2)+ where+ uni' t1' t2' = union'' f kf (norm t1') (norm t2')++ uni Empty Empty = empty+ uni Empty (Val v2 t2) = val v2 t2+ uni Empty (Branch c2 s2 n2)+ = branch c2 s2 n2++ uni (Val v1 t1) Empty = val v1 t1+ uni (Val v1 t1) (Val v2 t2) = val (f (kf []) v1 v2) (uni' t1 t2)+ uni (Val v1 t1) t2@(Branch _ _ _) = val v1 (uni' t1 t2)++ uni (Branch c1 s1 n1) Empty = branch c1 s1 n1+ uni t1@(Branch _ _ _ ) (Val v2 t2) = val v2 (uni' t1 t2) + uni t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = branch c1 s1 (uni' n1 t2)+ | c1 > c2 = branch c2 s2 (uni' t1 n2)+ | otherwise = branch c1 (union'' f (kf . (c1:)) s1 s2) (uni' n1 n2)++ uni _ _ = normError "union''"++-- ----------------------------------------+--+-- | /(O(min(n,m))/ Difference between two tries (based on keys).++difference :: PrefixTree a -> PrefixTree b -> PrefixTree a+difference = differenceWith (const (const Nothing))++-- | /(O(min(n,m))/ Difference with a combining function. If the combining function always returns+-- 'Nothing', this is equal to proper set difference.++differenceWith :: (a -> b -> Maybe a) -> PrefixTree a -> PrefixTree b -> PrefixTree a+differenceWith f = differenceWithKey (const f)++-- | /O(min(n,m))/ Difference with a combining function, including the key. If two equal keys are+-- encountered, the combining function is applied to the key and both values. If it returns+-- 'Nothing', the element is discarded, if it returns 'Just' a value, the element is updated+-- with the new value.++differenceWithKey :: (Key -> a -> b -> Maybe a) -> PrefixTree a -> PrefixTree b -> PrefixTree a+differenceWithKey f = diff'' f id++diff'' :: (Key -> a -> b -> Maybe a) ->+ (Key -> Key) ->+ PrefixTree a -> PrefixTree b -> PrefixTree a+diff'' f kf pt1 pt2 = dif (norm pt1) (norm pt2)+ where+ dif' t1' t2' = diff'' f kf (norm t1') (norm t2')++ dif Empty _ = empty++ dif (Val v1 t1) Empty = val v1 t1+ dif (Val v1 t1) (Val v2 t2) =+ case f (kf []) v1 v2 of+ Nothing -> dif' t1 t2+ Just nv -> val nv (dif' t1 t2)+ dif (Val v1 t1) t2@(Branch _ _ _) = val v1 (dif' t1 t2)++ dif (Branch c1 s1 n1) Empty = branch c1 s1 n1+ dif t1@(Branch _ _ _ ) (Val _ t2) = dif' t1 t2 + dif t1@(Branch c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = branch c1 s1 (dif' n1 t2)+ | c1 > c2 = dif' t1 n2+ | otherwise = branch c1 (diff'' f (kf . (c1:)) s1 s2) (dif' n1 n2)+ dif _ _ = normError "diff''"+++-- ----------------------------------------++-- | cut off all branches from a tree @t2@ that are not part of set @t1@+--+-- the following laws must holds+--+-- @lookup' k' . cutPx' (singlePS k) $ t == lookup' k t@ for every @k'@ with @k@ prefix of @k'@+--+-- @lookup' k' . cutPx' (singlePS k) $ t == Nothing@ for every @k'@ with @k@ not being a prefix of @k'@ + +cutPx'' :: (PrefixTree a -> PrefixTree a) -> PrefixSet -> PrefixTree a -> PrefixTree a+cutPx'' cf s1' t2' = cut s1' (norm t2')+ where+ cut PSempty _t2 = empty+ cut (PSelem _s1) t2 = cf t2+ cut (PSnext _ _ _ ) Empty = empty+ cut t1@(PSnext _ _ _ ) (Val _ t2) = cut t1 (norm t2)+ cut t1@(PSnext c1 s1 n1) t2@(Branch c2 s2 n2)+ | c1 < c2 = cut n1 t2+ | c1 > c2 = cut t1 (norm n2)+ | otherwise = branch c1 (cutPx'' cf s1 s2) (cutPx'' cf n1 n2)+ cut _ _ = normError "cutPx''"++cutPx' :: PrefixSet -> PrefixTree a -> PrefixTree a+cutPx' = cutPx'' id++cutAllPx' :: PrefixSet -> PrefixTree a -> PrefixTree a+cutAllPx' = cutPx'' (cv . norm)+ where+ cv (Val v _) = val v empty+ cv _ = empty++-- ----------------------------------------++-- | /O(n)/ Map a function over all values in the prefix tree.++map :: (a -> b) -> PrefixTree a -> PrefixTree b+map f = mapWithKey (const f)+++mapWithKey :: (Key -> a -> b) -> PrefixTree a -> PrefixTree b+mapWithKey f = map' f id+++map' :: (Key -> a -> b) -> (Key -> Key) -> PrefixTree a -> PrefixTree b+map' _ _ (Empty) = Empty+map' f k (Val v t) = Val (f (k []) v) (map' f k t)+map' f k (Branch c s n) = Branch c (map' f ((c :) . k) s) (map' f k n)+map' f k (Leaf v) = Leaf (f (k []) v)+map' f k (Last c s) = Last c (map' f ((c :) . k) s)+map' f k (LsSeq cs s) = LsSeq cs (map' f ((toKey cs ++) . k) s)+map' f k (BrSeq cs s n) = BrSeq cs (map' f ((toKey cs ++) . k) s) (map' f k n)+map' f k (LsSeL cs v) = LsSeL cs (f (k []) v)+map' f k (BrSeL cs v n) = BrSeL cs (f (k []) v) (map' f k n)+map' f k (LsVal c v) = LsVal c (f (k []) v)+map' f k (BrVal c v n) = BrVal c (f (k []) v) (map' f k n)++-- ----------------------------------------++-- | Variant of map that works on normalized trees++mapN :: (a -> b) -> PrefixTree a -> PrefixTree b+mapN f = mapWithKeyN (const f)+++mapWithKeyN :: (Key -> a -> b) -> PrefixTree a -> PrefixTree b+mapWithKeyN f = map'' f id++map'' :: (Key -> a -> b) -> (Key -> Key) -> PrefixTree a -> PrefixTree b+map'' f k = mapn . norm+ where+ mapn Empty = empty+ mapn (Val v t) = val (f (k []) v) (map'' f k t)+ mapn (Branch c s n) = branch c (map'' f ((c :) . k) s) (map'' f k n)+ mapn _ = normError "map''"++-- ----------------------------------------++-- | Monadic map++mapM :: Monad m => (a -> m b) -> PrefixTree a -> m (PrefixTree b)+mapM f = mapWithKeyM (const f)++-- | Monadic mapWithKey++mapWithKeyM :: Monad m => (Key -> a -> m b) -> PrefixTree a -> m (PrefixTree b)+mapWithKeyM f = mapM'' f id++mapM'' :: Monad m => (Key -> a -> m b) -> (Key -> Key) -> PrefixTree a -> m (PrefixTree b)+mapM'' f k = mapn . norm+ where+ mapn Empty = return $ empty+ mapn (Val v t) = do+ v' <- f (k []) v+ t' <- mapM'' f k t+ return $ val v' t'+ mapn (Branch c s n) = do+ s' <- mapM'' f ((c :) . k) s+ n' <- mapM'' f k n+ return $ branch c s' n'+ mapn _ = normError "mapM''"++-- ----------------------------------------+--+-- A prefix tree visitor++data PrefixTreeVisitor a b = PTV+ { v_empty :: b+ , v_val :: a -> b -> b+ , v_branch :: Sym -> b -> b -> b+ , v_leaf :: a -> b+ , v_last :: Sym -> b -> b+ , v_lsseq :: Key1 -> b -> b+ , v_brseq :: Key1 -> b -> b -> b+ , v_lssel :: Key1 -> a -> b+ , v_brsel :: Key1 -> a -> b -> b+ , v_lsval :: Sym -> a -> b+ , v_brval :: Sym -> a -> b -> b+ }++visit :: PrefixTreeVisitor a b -> PrefixTree a -> b++visit v (Empty) = v_empty v+visit v (Val v' t) = v_val v v' (visit v t)+visit v (Branch c s n) = v_branch v c (visit v s) (visit v n)+visit v (Leaf v') = v_leaf v v'+visit v (Last c s) = v_last v c (visit v s)+visit v (LsSeq cs s) = v_lsseq v cs (visit v s)+visit v (BrSeq cs s n) = v_brseq v cs (visit v s) (visit v n)+visit v (LsSeL cs v') = v_lssel v cs v'+visit v (BrSeL cs v' n) = v_brsel v cs v' (visit v n)+visit v (LsVal c v') = v_lsval v c v'+visit v (BrVal c v' n) = v_brval v c v' (visit v n)++-- ----------------------------------------+--+-- | space required by a prefix tree (logically)+--+-- Singletons are counted as 0, all other n-ary constructors+-- are counted as n+1 (1 for the constructor and 1 for every field)+-- cons nodes of char lists are counted 2, 1 for the cons, 1 for the char+-- for values only the ref to the value is counted, not the space for the value itself+-- key chars are assumed to be unboxed++space :: PrefixTree a -> Int+space = visit $+ PTV+ { v_empty = 0+ , v_val = const (3+)+ , v_branch = const $ \ s n -> 4 + s + n+ , v_leaf = const 2+ , v_last = const (3+)+ , v_lsseq = \ cs s -> 3 + 2 * length1 cs + s+ , v_brseq = \ cs s n -> 4 + 2 * length1 cs + s + n+ , v_lssel = \ cs _ -> 3 + 2 * length1 cs+ , v_brsel = \ cs _ n -> 4 + 2 * length1 cs + n+ , v_lsval = \ _ _ -> 3+ , v_brval = \ _ _ n -> 4 + n+ }++keyChars :: PrefixTree a -> Int+keyChars = visit $+ PTV+ { v_empty = 0+ , v_val = \ _ t -> t+ , v_branch = \ _ s n -> 1 + s + n+ , v_leaf = \ _ -> 0+ , v_last = \ _ s -> 1 + s+ , v_lsseq = \ cs s -> length1 cs + s+ , v_brseq = \ cs s n -> length1 cs + s + n+ , v_lssel = \ cs _ -> length1 cs+ , v_brsel = \ cs _ n -> length1 cs + n+ , v_lsval = \ _ _ -> 1+ , v_brval = \ _ _ n -> 1 + n+ }++-- ----------------------------------------+--+-- | statistics about the # of different nodes in an optimized prefix tree++stat :: PrefixTree a -> PrefixTree Int+stat = visit $+ PTV+ { v_empty = singleton "empty" 1+ , v_val = \ _ t -> singleton "val" 1 `add` t+ , v_branch = \ _ s n -> singleton "branch" 1 `add` (s `add` n)+ , v_leaf = \ _ -> singleton "leaf" 1+ , v_last = \ _ s -> singleton "last" 1 `add` s+ , v_lsseq = \ cs s -> singleton ("lsseq-" ++ show (length1 cs)) 1 `add` s+ , v_brseq = \ cs s n -> singleton ("brseq-" ++ show (length1 cs)) 1 `add` (s `add` n)+ , v_lssel = \ cs _ -> singleton ("lssel-" ++ show (length1 cs)) 1+ , v_brsel = \ cs _ n -> singleton ("brseq-" ++ show (length1 cs)) 1 `add` n+ , v_lsval = \ _ _ -> singleton "lsval" 1+ , v_brval = \ _ _ n -> singleton "brval" 1 `add` n+ }+ where+ add = unionWith (+)++-- ----------------------------------------++-- | /O(n)/ Fold over all key\/value pairs in the map.++foldWithKey :: (Key -> a -> b -> b) -> b -> PrefixTree a -> b+foldWithKey f e = fold' f e id++{-# INLINE foldWithKey #-}++-- | /O(n)/ Fold over all values in the map.++fold :: (a -> b -> b) -> b -> PrefixTree a -> b+fold f = foldWithKey $ const f++{-# INLINE fold #-}++{- not yet used++foldTopDown :: (Key -> a -> b -> b) -> b -> (Key -> Key) -> PrefixTree a -> b+foldTopDown f r k0 = fo k0 . norm+ where+ fo kf (Branch c' s' n') = let r' = foldTopDown f r ((c' :) . kf) s' in foldTopDown f r' kf n'+ fo _ (Empty) = r+ fo kf (Val v' t') = let r' = f (kf []) v' r in foldTopDown f r' kf t'+ fo _ _ = normError "foldTopDown"+-- -}++fold' :: (Key -> a -> b -> b) -> b -> (Key -> Key) -> PrefixTree a -> b+fold' f r k0 = fo k0 . norm+ where+ fo kf (Branch c' s' n') = let r' = fold' f r kf n' in fold' f r' (kf . (c':)) s'+ fo _ (Empty) = r+ fo kf (Val v' t') = let r' = fold' f r kf t' in f (kf []) v' r'+ fo _ _ = normError "fold'"++-- | /O(n)/ Convert into an ordinary map.++toMap :: PrefixTree a -> M.Map Key a+toMap = foldWithKey M.insert M.empty++-- | /O(n)/ Convert an ordinary map into a Prefix tree++fromMap :: M.Map Key a -> PrefixTree a+fromMap = M.foldrWithKey insert empty++-- | /O(n)/ Returns all elements as list of key value pairs,++toList :: PrefixTree a -> [(Key, a)]+toList = foldWithKey (\k v r -> (k, v) : r) []++-- | /O(n)/ Creates a trie from a list of key\/value pairs.+fromList :: [(Key, a)] -> PrefixTree a+fromList = L.foldl' (\p (k, v) -> insert k v p) empty++-- | /O(n)/ The number of elements.+size :: PrefixTree a -> Int+size = fold (const (+1)) 0++-- | /O(n)/ Returns all values.+elems :: PrefixTree a -> [a]+elems = fold (:) []++-- | /O(n)/ Returns all values.+keys :: PrefixTree a -> [Key]+keys = foldWithKey (\ k _v r -> k : r) []++-- ----------------------------------------++-- | returns all key-value pairs in breadth first order (short words first)+-- this enables prefix search with upper bounds on the size of the result set+-- e.g. @ search ... >>> toListBF >>> take 1000 @ will give the 1000 shortest words+-- found in the result set and will ignore all long words+--+-- toList is derived from the following code found in the net when searching haskell breadth first search+--+-- Haskell Standard Libraray Implementation+--+-- > br :: Tree a -> [a]+-- > br t = map rootLabel $+-- > concat $+-- > takeWhile (not . null) $ +-- > iterate (concatMap subForest) [t]++toListBF :: PrefixTree v -> [(Key, v)]+toListBF = (\ t0 -> [(id, t0)])+ >>>+ iterate (concatMap (second norm >>> uncurry subForest))+ >>>+ takeWhile (not . L.null)+ >>>+ concat+ >>>+ concatMap (second norm >>> uncurry rootLabel)++rootLabel :: (Key -> Key) -> PrefixTree v -> [(Key, v)]+rootLabel kf (Val v _) = [(kf [], v)]+rootLabel _ _ = []++subForest :: (Key -> Key) -> PrefixTree v -> [(Key -> Key, PrefixTree v)]+subForest kf (Branch c s n) = (kf . (c:), s) : subForest kf (norm n)+subForest _ Empty = []+subForest kf (Val _ t) = subForest kf (norm t)+subForest _ _ = error "PrefixTree.Core.subForest: Pattern match failure"+ +-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key and include the keys +-- in the result. The result list contains short words first++prefixFindWithKeyBF :: Key -> PrefixTree a -> [(Key, a)]+prefixFindWithKeyBF k = fmap (first (k ++)) . toListBF . lookupPx' k++-- ----------------------------------------++instance Functor PrefixTree where+ fmap = map++instance Data.Foldable.Foldable PrefixTree where+ foldr = fold++{- for debugging not yet enabled++instance Show a => Show (PrefixTree a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++-- -}++-- ----------------------------------------++instance Read a => Read (PrefixTree a) where+ readsPrec p = readParen (p > 10) $+ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)++-- ----------------------------------------++instance NFData a => NFData (PrefixTree a) where+ rnf (Empty) = ()+ rnf (Val v t) = rnf v `seq` rnf t+ rnf (Branch _c s n) = rnf s `seq` rnf n+ rnf (Leaf v) = rnf v+ rnf (Last _c s) = rnf s+ rnf (LsSeq _ks s) = rnf s+ rnf (BrSeq _ks s n) = rnf s `seq` rnf n+ rnf (LsSeL _ks v) = rnf v+ rnf (BrSeL _ks v n) = rnf v `seq` rnf n+ rnf (LsVal k v) = rnf k `seq` rnf v+ rnf (BrVal k v n) = rnf k `seq` rnf v `seq` rnf n++-- ----------------------------------------+--+-- Provide native binary serialization (not via to-/fromList).++instance (Binary a) => Binary (PrefixTree a) where+ put (Empty) = put (0::Word8)+ put (Val v t) = put (1::Word8) >> put v >> put t+ put (Branch c s n) = put (2::Word8) >> put c >> put s >> put n+ put (Leaf v) = put (3::Word8) >> put v+ put (Last c s) = put (4::Word8) >> put c >> put s+ put (LsSeq k s) = put (5::Word8) >> put (toKey k) >> put s+ put (BrSeq k s n) = put (6::Word8) >> put (toKey k) >> put s >> put n+ put (LsSeL k v) = put (7::Word8) >> put (toKey k) >> put v+ put (BrSeL k v n) = put (8::Word8) >> put (toKey k) >> put v >> put n+ put (LsVal k v) = put (9::Word8) >> put k >> put v+ put (BrVal k v n) = put (10::Word8) >> put k >> put v >> put n++ get = do+ !tag <- getWord8+ case tag of+ 0 -> return Empty+ 1 -> do+ !v <- get+ !t <- get+ return $! Val v t+ 2 -> do+ !c <- get+ !s <- get+ !n <- get+ return $! Branch c s n+ 3 -> do+ !v <- get+ return $! Leaf v+ 4 -> do+ !c <- get+ !s <- get+ return $! Last c s+ 5 -> do+ !k <- get+ !s <- get+ return $! LsSeq (fromKey k) s+ 6 -> do+ !k <- get+ !s <- get+ !n <- get+ return $! BrSeq (fromKey k) s n+ 7 -> do+ !k <- get+ !v <- get+ return $! LsSeL (fromKey k) v+ 8 -> do+ !k <- get+ !v <- get+ !n <- get+ return $! BrSeL (fromKey k) v n+ 9 -> do+ !k <- get+ !v <- get+ return $! LsVal k v+ 10 -> do+ !k <- get+ !v <- get+ !n <- get+ return $! BrVal k v n+ _ -> fail "PrefixTree.get: error while decoding PrefixTree"++-- ----------------------------------------
+ src/Holumbus/Data/PrefixTree/FuzzySearch.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS -XBangPatterns #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Data.PrefixTree.FuzzySearch+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ Functions for fuzzy search in a prefix tree+ +-}++-- ----------------------------------------------------------------------------++module Holumbus.Data.PrefixTree.FuzzySearch+where++import Data.Char++import Holumbus.Data.PrefixTree.Core+import Holumbus.Data.PrefixTree.PrefixSet+import Holumbus.Data.PrefixTree.Types++-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key.++prefixFindCaseWithKey :: Key -> PrefixTree a -> [(Key, a)] +prefixFindCaseWithKey k = toList . cutPx' (singlePS k) ++prefixFindNoCaseWithKey :: Key -> PrefixTree a -> [(Key, a)] +prefixFindNoCaseWithKey k = toList . cutPx' (noCaseKeys k) ++prefixFindNoCase :: Key -> PrefixTree a -> [a] +prefixFindNoCase k = elems . cutPx' (noCaseKeys k)++lookupNoCase :: Key -> PrefixTree a -> [(Key, a)]+lookupNoCase k = toList . cutAllPx' (noCaseKeys k)++-- ----------------------------------------++-- | /O(max(L,R))/ Find all values where the string is a prefix of the key.+-- Breadth first variant, short words first in the result list++prefixFindCaseWithKeyBF :: Key -> PrefixTree a -> [(Key, a)] +prefixFindCaseWithKeyBF k = toListBF . cutPx' (singlePS k) ++prefixFindNoCaseWithKeyBF :: Key -> PrefixTree a -> [(Key, a)] +prefixFindNoCaseWithKeyBF k = toListBF . cutPx' (noCaseKeys k) ++lookupNoCaseBF :: Key -> PrefixTree a -> [(Key, a)]+lookupNoCaseBF k = toListBF . cutAllPx' (noCaseKeys k)++-- ----------------------------------------++noCaseKeys :: Key -> PrefixSet+noCaseKeys = noCasePS . singlePS++noLowerCaseKeys :: Key -> PrefixSet+noLowerCaseKeys = noLowerCasePS . singlePS++-- ----------------------------------------+++noCasePS :: PrefixSet -> PrefixSet+noCasePS = fuzzyCharPS (\ x -> [toUpper x, toLower x])+ +noLowerCasePS :: PrefixSet -> PrefixSet+noLowerCasePS = fuzzyCharPS (\ x -> [toUpper x, x])++-- ----------------------------------------++noUmlautPS :: PrefixSet -> PrefixSet+noUmlautPS = fuzzyCharsPS noUmlaut+ where+ noUmlaut '\196' = ["Ae"]+ noUmlaut '\214' = ["Oe"]+ noUmlaut '\220' = ["Ue"]+ noUmlaut '\228' = ["ae"]+ noUmlaut '\246' = ["oe"]+ noUmlaut '\252' = ["ue"]+ noUmlaut '\223' = ["ss"]+ noUmlaut c = [[c]]++-- ------------------------------------------------------------+{- a few simple tests++e1 = singlePS "abc"+e2 = prefixPS "abc"+e3 = foldl unionPS emptyPS . fmap singlePS $ ["zeus","anna","anton","an"]+e4 = noCasePS e3+e5 = noLowerCasePS . singlePS $ "Data"+e6 = noUmlautPS . singlePS $ "äöüzß"++-- -}+-- ------------------------------------------------------------
+ src/Holumbus/Data/PrefixTree/PrefixSet.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -XBangPatterns #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Data.PrefixTree.PrefixSet+ Copyright : Copyright (C) 2010 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: not portable++ A simplified version of PrefixTree for implementing sets.++ There is one important difference to the PrefixTree implementation:+ The fields are not marked to be strict. This enables building the+ set on the fly.++ This feature is used in fuzzy search, when an index tree is restricted+ to a set of keys, e.g. the set of all none case significant keys+ +-}++-- ----------------------------------------------------------------------------++module Holumbus.Data.PrefixTree.PrefixSet+where++import Data.List ( sort, nub )++import Holumbus.Data.PrefixTree.Types++-- ----------------------------------------++-- | Set of strings implemented as lazy prefix tree.+-- @type PrefixSet = PrefixTree ()@ is not feasable because of the strict fields in the PrefixTree definition++data PrefixSet = PSempty+ | PSelem PrefixSet+ | PSnext Sym PrefixSet PrefixSet+ deriving (Show)++emptyPS :: PrefixSet+emptyPS = PSempty++elemPS :: PrefixSet -> PrefixSet+elemPS s@(PSelem _) = s+elemPS s = PSelem s++elem0PS :: PrefixSet+elem0PS = elemPS emptyPS++nextPS :: Sym -> PrefixSet -> PrefixSet -> PrefixSet+nextPS _ PSempty n = n+nextPS s c n = PSnext s c n++lastPS :: Sym -> PrefixSet -> PrefixSet+lastPS s c = nextPS s c emptyPS++nullPS :: PrefixSet -> Bool+nullPS PSempty = True+nullPS _ = False++singlePS :: Key -> PrefixSet+singlePS = foldr (\ c r -> lastPS c r) elem0PS++-- ------------------------------------------------------------++prefixPS :: Key -> PrefixSet+prefixPS = foldr (\ c r -> elemPS (lastPS c r)) elem0PS++-- ------------------------------------------------------------++unionPS :: PrefixSet -> PrefixSet -> PrefixSet+unionPS PSempty ps2 = ps2+unionPS ps1 PSempty = ps1++unionPS (PSelem ps1) (PSelem ps2) = PSelem (unionPS ps1 ps2)+unionPS (PSelem ps1) ps2 = PSelem (unionPS ps1 ps2)+unionPS ps1 (PSelem ps2) = PSelem (unionPS ps1 ps2)++unionPS ps1@(PSnext c1 s1 n1)+ ps2@(PSnext c2 s2 n2)+ | c1 < c2 = nextPS c1 s1 (unionPS n1 ps2)+ | c1 > c2 = nextPS c2 s2 (unionPS ps1 n2)+ | otherwise = nextPS c1 (unionPS s1 s2) (unionPS n1 n2)++-- ------------------------------------------------------------++foldPS :: (Key -> b -> b) -> b -> (Key -> Key) -> PrefixSet -> b+foldPS _ r _ PSempty = r+foldPS f r kf (PSelem ps1) = let r' = foldPS f r kf ps1+ in+ f (kf []) r'+foldPS f r kf (PSnext c1 s1 n1) = let r' = foldPS f r kf n1+ in+ foldPS f r' (kf . (c1:)) s1++foldWithKeyPS :: (Key -> b -> b) -> b -> PrefixSet -> b+foldWithKeyPS f e = foldPS f e id++-- ------------------------------------------------------------++elemsPS :: PrefixSet -> [Key]+elemsPS = foldWithKeyPS (:) []++-- ------------------------------------------------------------++fuzzyCharPS :: (Sym -> [Sym]) -> PrefixSet -> PrefixSet+fuzzyCharPS _ PSempty = PSempty+fuzzyCharPS f (PSelem ps) = PSelem $ fuzzyCharPS f ps+fuzzyCharPS f (PSnext c s n) = unionPS ps1 (fuzzyCharPS f n)+ where+ s' = fuzzyCharPS f s+ cs = sort . nub . f $ c+ ps1 = foldr (\ c' r' -> nextPS c' s' r') emptyPS $ cs++-- ------------------------------------------------------------++fuzzyCharsPS :: (Sym -> [Key]) -> PrefixSet -> PrefixSet+fuzzyCharsPS _ PSempty = PSempty+fuzzyCharsPS f (PSelem ps) = PSelem $ fuzzyCharsPS f ps+fuzzyCharsPS f (PSnext c s n) = unionPS ps1 (fuzzyCharsPS f n)+ where+ s' = fuzzyCharsPS f s+ cs = sort . nub . f $ c+ ps1 = foldr (\ w' r' -> nextPSw w' s' r') emptyPS $ cs+ nextPSw [] _ r' = r'+ nextPSw (x:xs) s'' r' = nextPS x (foldr lastPS s'' xs) r'++-- ------------------------------------------------------------
+ src/Holumbus/Data/PrefixTree/Types.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Data.PrefixTree.Types+ Copyright : Copyright (C) 2009-2012 Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable++ Data types used in all PrefixTree modules++-}++-- ----------------------------------------------------------------------------++module Holumbus.Data.PrefixTree.Types+where++type Sym = Char+type Key = [Sym]++-- ----------------------------------------------------------------------------
+ src/Holumbus/Index/Common.hs view
@@ -0,0 +1,308 @@+{-# OPTIONS -XMultiParamTypeClasses -XFlexibleContexts -XFlexibleInstances -XGeneralizedNewtypeDeriving -XTypeSynonymInstances -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common+ Copyright : Copyright (C) 2007 Sebastian M. Schlatt, Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ Common data types shared by all index types and a unified interface for+ all different index types. This module defines the common interfaces of+ indexes and their document tables as well as full-text caches.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common + (+ -- * Common index types and classes+ HolIndex (..)+ , HolIndexM (..)+ , HolDocuments (..)+ , HolDocIndex (..)+ , HolCache (..)++ -- * Indexes and Documents+ -- , mergeAll++ , module Holumbus.Index.Common.BasicTypes+ , module Holumbus.Index.Common.Document+ , module Holumbus.Index.Common.DocId+ , module Holumbus.Index.Common.DocIdMap+ , module Holumbus.Index.Common.Occurences+ , module Holumbus.Index.Common.RawResult+ , module Holumbus.Index.Common.LoadStore++ )+where++import Control.Monad ( foldM )++-- import Data.Binary ( Binary (..) )+-- import Data.Maybe++import Holumbus.Index.Common.BasicTypes+import Holumbus.Index.Common.Document+import Holumbus.Index.Common.DocId+import Holumbus.Index.Common.DocIdMap+import Holumbus.Index.Common.Occurences+import Holumbus.Index.Common.RawResult+import Holumbus.Index.Common.LoadStore++-- ------------------------------------------------------------++-- | This class provides a generic interface to different types of index implementations.++class HolIndex i where+ -- | Returns the number of unique words in the index.+ sizeWords :: i -> Int++ -- | Returns a list of all contexts avaliable in the index.+ contexts :: i -> [Context]++ -- | Returns the occurrences for every word. A potentially expensive operation.+ allWords :: i -> Context -> RawResult++ -- | Searches for words beginning with the prefix in a given context (case-sensitive).+ prefixCase :: i -> Context -> String -> RawResult++ -- | Searches for words beginning with the prefix in a given context (case-insensitive).+ prefixNoCase :: i -> Context -> String -> RawResult++ -- | Searches for and exact word in a given context (case-sensitive).+ lookupCase :: i -> Context -> String -> RawResult++ -- | Searches for and exact word in a given context (case-insensitive).+ lookupNoCase :: i -> Context -> String -> RawResult+ + -- | Insert occurrences.+ insertOccurrences :: Context -> Word -> Occurrences -> i -> i++ -- | Delete occurrences.+ deleteOccurrences :: Context -> Word -> Occurrences -> i -> i++ -- | Insert a position for a single document.+ insertPosition :: Context -> Word -> DocId -> Position -> i -> i+ insertPosition c w d p i = insertOccurrences c w (singletonOccurrence d p) i++ -- | Delete a position for a single document.+ deletePosition :: Context -> Word -> DocId -> Position -> i -> i+ deletePosition c w d p i = deleteOccurrences c w (singletonOccurrence d p) i++ -- | Merges two indexes. + mergeIndexes :: i -> i -> i++ -- | Substract one index from another.+ substractIndexes :: i -> i -> i++ -- | Splitting an index by its contexts.+ splitByContexts :: i -> Int -> [i]++ -- | Splitting an index by its documents.+ splitByDocuments :: i -> Int -> [i]++ -- | Splitting an index by its words.+ splitByWords :: i -> Int -> [i]++ -- | Update document id's (e.g. for renaming documents). If the function maps two different id's+ -- to the same new id, the two sets of word positions will be merged if both old id's are present+ -- in the occurrences for a word in a specific context.+ updateDocIds :: (Context -> Word -> DocId -> DocId) -> i -> i++ -- | Update document id's with a simple injective editing function.+ updateDocIds' :: (DocId -> DocId) -> i -> i+ updateDocIds' f = updateDocIds (const . const $ f)++ -- Convert an Index to a list. Can be used for easy conversion between different index + -- implementations++ toList :: i -> [(Context, Word, Occurrences)]+ + -- Create an Index from a list. Can be used for easy conversion between different index + -- implementations. Needs an empty index as first argument++ fromList :: i -> [(Context, Word, Occurrences)] -> i+ fromList e = foldl (\i (c,w,o) -> insertOccurrences c w o i) e++-- ------------------------------------------------------------++-- | This class provides a generic interface to different monadic types of index implementations.++class (Monad m) => HolIndexM m i where+ -- | Returns the number of unique words in the index.+ sizeWordsM :: i -> m Int++ -- | Returns a list of all contexts avaliable in the index.+ contextsM :: i -> m [Context]++ -- | Returns the occurrences for every word. A potentially expensive operation.+ allWordsM :: i -> Context -> m RawResult++ -- | Searches for words beginning with the prefix in a given context (case-sensitive).+ prefixCaseM :: i -> Context -> String -> m RawResult++ -- | Searches for words beginning with the prefix in a given context (case-insensitive).+ prefixNoCaseM :: i -> Context -> String -> m RawResult++ -- | Searches for and exact word in a given context (case-sensitive).+ lookupCaseM :: i -> Context -> String -> m RawResult++ -- | Searches for and exact word in a given context (case-insensitive).+ lookupNoCaseM :: i -> Context -> String -> m RawResult++ -- | Insert occurrences.+ insertOccurrencesM :: Context -> Word -> Occurrences -> i -> m i++ -- | Delete occurrences.+ deleteOccurrencesM :: Context -> Word -> Occurrences -> i -> m i++ -- | Insert a position for a single document.+ insertPositionM :: Context -> Word -> DocId -> Position -> i -> m i+ insertPositionM c w d p i = insertOccurrencesM c w (singletonOccurrence d p) i++ -- | Delete a position for a single document.+ deletePositionM :: Context -> Word -> DocId -> Position -> i -> m i+ deletePositionM c w d p i = deleteOccurrencesM c w (singletonOccurrence d p) i++ -- | Merges two indexes. + mergeIndexesM :: i -> i -> m i++ -- | Update document id's (e.g. for renaming documents). If the function maps two different id's+ -- to the same new id, the two sets of word positions will be merged if both old id's are present+ -- in the occurrences for a word in a specific context.+ updateDocIdsM :: (Context -> Word -> DocId -> DocId) -> i -> m i++ -- | Update document id's with an simple injective editing function.+ updateDocIdsM' :: (DocId -> DocId) -> i -> m i++ -- Convert an Index to a list. Can be used for easy conversion between different index + -- implementations+ toListM :: i -> m [(Context, Word, Occurrences)]++ -- Create an Index from a list. Can be used vor easy conversion between different index + -- implementations. Needs an empty index as first argument+ fromListM :: i -> [(Context, Word, Occurrences)] -> m i+ fromListM e = foldM (\i (c,w,o) -> insertOccurrencesM c w o i) e++-- ------------------------------------------------------------++-- don't change IO into Monad m+-- this leads to ambiguities and error messages, when a context (HolIndexM m i) is used+--+-- NOT: instance (Monad m, HolIndex i) => HolIndexM m i where++instance (HolIndex i) => HolIndexM IO i where+ sizeWordsM = return . sizeWords+ contextsM = return . contexts+ allWordsM i = return . allWords i+ prefixCaseM i c = return . prefixCase i c+ prefixNoCaseM i c = return . prefixNoCase i c+ lookupCaseM i c = return . lookupCase i c+ lookupNoCaseM i c = return . lookupNoCase i c+ insertOccurrencesM c w o = return . insertOccurrences c w o+ deleteOccurrencesM c w o = return . deleteOccurrences c w o+ mergeIndexesM i1 = return . mergeIndexes i1+ updateDocIdsM u = return . updateDocIds u+ updateDocIdsM' f = return . updateDocIds (const . const $ f)+ toListM = return . toList++-- ------------------------------------------------------------++class HolDocuments d a where+ -- | doctable empty?+ nullDocs :: d a -> Bool+ nullDocs = (== 0) . sizeDocs++ -- | Returns the number of unique documents in the table.+ sizeDocs :: d a -> Int+ + -- | Lookup a document by its id.+ lookupById :: Monad m => d a -> DocId -> m (Document a)++ -- | Lookup the id of a document by an URI.+ lookupByURI :: Monad m => d a -> URI -> m DocId++ -- | Union of two disjoint document tables. It is assumed, that the DocIds and the document uris+ -- of both indexes are disjoint. If only the sets of uris are disjoint, the DocIds can be made+ -- disjoint by adding maxDocId of one to the DocIds of the second, e.g. with editDocIds++ unionDocs :: d a -> d a -> d a+ unionDocs dt1 = foldDocIdMap addDoc dt1 . toMap+ where+ addDoc d dt = snd . insertDoc dt $ d++ -- | Test whether the doc ids of both tables are disjoint+ disjointDocs :: d a -> d a -> Bool++ -- | Return an empty document table. The input parameter is taken to identify the typeclass+ makeEmpty :: d a -> d a+ + -- | Insert a document into the table. Returns a tuple of the id for that document and the + -- new table. If a document with the same URI is already present, its id will be returned + -- and the table is returned unchanged.++ insertDoc :: d a -> (Document a) -> (DocId, d a)++ -- | Update a document with a certain DocId. + updateDoc :: d a -> DocId -> (Document a) -> d a++ -- | Removes the document with the specified id from the table.+ removeById :: d a -> DocId -> d a++ -- | Removes the document with the specified URI from the table.+ removeByURI :: d a -> URI -> d a+ removeByURI ds u = maybe ds (removeById ds) (lookupByURI ds u)++ -- | Update documents (through mapping over all documents).+ updateDocuments :: (Document a -> Document a) -> d a -> d a++ filterDocuments :: (Document a -> Bool) -> d a -> d a++ -- | Create a document table from a single map.+ fromMap :: DocIdMap (Document a) -> d a++ -- | Convert document table to a single map+ toMap :: d a -> DocIdMap (Document a)++ -- | Edit document ids+ editDocIds :: (DocId -> DocId) -> d a -> d a+ editDocIds f = fromMap . foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap . toMap++-- ------------------------------------------------------------++class HolCache c where+ -- | Retrieves the full text of a document for a given context. Will never throw any exception,+ -- upon failure or if no text found for the document, @Nothing@ is returned.+ getDocText :: c -> Context -> DocId -> IO (Maybe Content)++ -- | Store the full text of a document for a given context. May throw an exception if the + -- storage of the text failed.++ putDocText :: c -> Context -> DocId -> Content -> IO ()+ -- | Merge two caches in the way that everything that is in the second cache is inserted into the+ -- first one.++ mergeCaches :: c -> c -> IO c++-- ------------------------------------------------------------++class (HolDocuments d a, HolIndex i) => HolDocIndex d a i where++ -- | Merge two doctables and indexes together into a single doctable and index+ unionDocIndex :: d a -> i -> d a -> i -> (d a, i)++ -- | Defragment a doctable and index, useful when the doc ids are+ -- organized as an intervall of ints.+ --+ -- Default implementation is the identity++ defragmentDocIndex :: d a -> i -> (d a, i)+ defragmentDocIndex = (,)++-- ------------------------------------------------------------
+ src/Holumbus/Index/Common/BasicTypes.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.BasicTypes+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ Basic data types for index++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.BasicTypes+where++import Data.Word ( Word32 )++-- ------------------------------------------------------------++-- | The URI describing the location of the original document.+type URI = String++-- | The title of a document.+type Title = String++-- | The content of a document.+type Content = String++-- | The position of a word in the document.+--type Position = Int+type Position = Word32++-- | The name of a context.+type Context = String++-- | A single word.+type Word = String++-- ------------------------------------------------------------
+ src/Holumbus/Index/Common/DiffList.hs view
@@ -0,0 +1,108 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.DiffList+ Copyright : Copyright (C) 2011 Timo B. Huebel, Uwe Schmidt+ License : MIT+ + Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.1+ + Providing space efficient difference encoding for lists of integers. The encoded+ lists are compressed using "Holumbus.Data.Crunch" to save even more space. For+ convenience, conversion functions for "Data.IntSet" are provided. Only works+ for non-negative integers.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.DiffList + (+ -- * DiffList types+ DiffList+ + -- * Conversion+ , fromPositions+ , toPositions+ , fromList+ , toList+ + -- * Debug+ , diffs+ )+where++import Data.List+import Data.Word ( Word32+ , Word64+ )++import Holumbus.Data.Crunch++import Holumbus.Index.Common.BasicTypes ( Position )+import Holumbus.Index.Common.Occurences ( Positions+ , fromListPos+ , toAscListPos+ )++-- ----------------------------------------------------------------------------++-- | A single difference between two integers.+type Diff = Word64++-- | A list of differences.+type DiffList = [Diff]++-- | Convert a set of integers into a list of difference encoded values.++fromPositions :: Positions -> DiffList+fromPositions = fromList . toAscListPos++-- | Convert the difference encoded values to a list of integers.++toPositions :: DiffList -> Positions+toPositions = fromListPos . toList++-- | Convert a list of positions into a list of difference encoded values.++fromList :: [Position] -> DiffList+fromList = crunch32 . encode . sort++-- | Convert the difference encoded values to a list of integers.+-- The resulting list will be+-- sorted in ascending order++toList :: DiffList -> [Position]+toList = decode . decrunch32++-- | This is were the real work is done: Encoding a sorted list of integers.++encode :: [Position] -> [Word32]+encode = encode' 0+ where+ encode' :: Word32 -> [Position] -> [Word32]+ encode' _ [] = []+ encode' l (x:xs) = n:(encode' x xs)+ where+ n = fromIntegral (x - l)++-- | This is were the real work is done: Decoding a difference list.++decode :: [Word32] -> [Position]+decode = decode' 0+ where+ decode' :: Position -> [Word32] -> [Position]+ decode' _ [] = []+ decode' l (x:xs) = n:(decode' n xs)+ where+ n = (fromIntegral x) + l ++-- | Returns all differences. Used for debugging purposes.++diffs :: DiffList -> [Word32]+diffs = decrunch32++-- ----------------------------------------------------------------------------
+ src/Holumbus/Index/Common/DocId.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS -XGeneralizedNewtypeDeriving #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.DocId+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ The document identifier type DocId++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.DocId+where++import Control.DeepSeq++import Data.Binary ( Binary (..) )+import qualified+ Data.Binary as B+import Data.Word ( Word64 )++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | The unique identifier of a document+-- (created upon insertion into the document table).++newtype DocId = DocId { theDocId :: Word64 }+ deriving (Eq, Ord, Enum)+instance Show DocId where+ show = show . theDocId++instance NFData DocId where+ rnf (DocId i) = rnf i++instance Binary DocId where+ put = B.put . theDocId+ get = B.get >>= return . DocId++incrDocId :: DocId -> DocId+incrDocId = DocId . (1+) . theDocId++nullDocId :: DocId+nullDocId = DocId 0++firstDocId :: DocId+firstDocId = DocId 1++mkDocId :: Word64 -> DocId+mkDocId = DocId++xpDocId :: PU DocId+xpDocId = xpWrap (DocId, theDocId) xpPrim++-- ------------------------------------------------------------
+ src/Holumbus/Index/Common/DocIdMap.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS -XTypeSynonymInstances -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.DocIdMap+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ DocId maps++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.DocIdMap+where++import Control.DeepSeq++import Data.Binary ( Binary (..) )+import qualified+ Data.Binary as B+import qualified+ Data.EnumMap as IM++import Holumbus.Index.Common.DocId++-- import Text.XML.HXT.Core++-- ------------------------------------------------------------++type DocIdMap v = IM.EnumMap DocId v++emptyDocIdMap :: DocIdMap v+emptyDocIdMap = IM.empty++singletonDocIdMap :: DocId -> v -> DocIdMap v+singletonDocIdMap d v = insertDocIdMap d v emptyDocIdMap++nullDocIdMap :: DocIdMap v -> Bool+nullDocIdMap = IM.null++memberDocIdMap :: DocId -> DocIdMap v -> Bool+memberDocIdMap = IM.member++lookupDocIdMap :: DocId -> DocIdMap v -> Maybe v+lookupDocIdMap = IM.lookup++insertDocIdMap :: DocId -> v -> DocIdMap v -> DocIdMap v+insertDocIdMap = IM.insert++deleteDocIdMap :: DocId -> DocIdMap v -> DocIdMap v+deleteDocIdMap = IM.delete++insertWithDocIdMap :: (v -> v -> v) -> DocId -> v -> DocIdMap v -> DocIdMap v+insertWithDocIdMap = IM.insertWith++sizeDocIdMap :: DocIdMap v -> Int+sizeDocIdMap = IM.size++minKeyDocIdMap :: DocIdMap v -> DocId+minKeyDocIdMap = maybe nullDocId (fst . fst) . IM.minViewWithKey++maxKeyDocIdMap :: DocIdMap v -> DocId+maxKeyDocIdMap = maybe nullDocId (fst . fst) . IM.maxViewWithKey++isIntervallDocIdMap :: DocIdMap v -> Bool+isIntervallDocIdMap m = nullDocIdMap m+ ||+ ( fromEnum (theDocId (minKeyDocIdMap m) - theDocId (maxKeyDocIdMap m))+ == sizeDocIdMap m+ )++unionDocIdMap :: DocIdMap v -> DocIdMap v -> DocIdMap v+unionDocIdMap = IM.union++differenceDocIdMap :: DocIdMap v -> DocIdMap v -> DocIdMap v+differenceDocIdMap = IM.difference++unionWithDocIdMap :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v+unionWithDocIdMap = IM.unionWith++intersectionWithDocIdMap :: (v -> v -> v) -> DocIdMap v -> DocIdMap v -> DocIdMap v+intersectionWithDocIdMap = IM.intersectionWith++unionsWithDocIdMap :: (v -> v -> v) -> [DocIdMap v] -> DocIdMap v+unionsWithDocIdMap = IM.unionsWith++mapDocIdMap :: (v -> r) -> DocIdMap v -> DocIdMap r+mapDocIdMap = IM.map++filterDocIdMap :: (v -> Bool) -> DocIdMap v -> DocIdMap v+filterDocIdMap = IM.filter++filterWithKeyDocIdMap :: (DocId -> v -> Bool) -> DocIdMap v -> DocIdMap v+filterWithKeyDocIdMap = IM.filterWithKey++mapWithKeyDocIdMap :: (DocId -> v -> r) -> DocIdMap v -> DocIdMap r+mapWithKeyDocIdMap = IM.mapWithKey++foldDocIdMap :: (v -> b -> b) -> b -> DocIdMap v -> b+foldDocIdMap = IM.fold++foldWithKeyDocIdMap :: (DocId -> v -> b -> b) -> b -> DocIdMap v -> b+foldWithKeyDocIdMap = IM.foldWithKey++fromListDocIdMap :: [(DocId, v)] -> DocIdMap v+fromListDocIdMap = IM.fromList++toListDocIdMap :: DocIdMap v -> [(DocId, v)]+toListDocIdMap = IM.toList++keysDocIdMap :: DocIdMap v -> [DocId]+keysDocIdMap = IM.keys++elemsDocIdMap :: DocIdMap v -> [v]+elemsDocIdMap = IM.elems++instance NFData v => NFData (DocIdMap v) where+ rnf m = rnf (IM.toList m)++instance Binary v => Binary (DocIdMap v) where+ put = B.put . IM.toList+ get = B.get >>= return . IM.fromList++-- ------------------------------------------------------------
+ src/Holumbus/Index/Common/Document.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.Document+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ The Document datatype++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.Document+where++import Control.Monad ( liftM3 )+import Control.DeepSeq++import Data.Binary ( Binary (..) )+import qualified+ Data.Binary as B++import Holumbus.Index.Common.BasicTypes++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | A document consists of a title and its unique identifier (URI)+-- and a customizable component++data Document a = Document+ { title :: ! Title+ , uri :: ! URI+ , custom :: ! (Maybe a)+ }+ deriving (Show, Eq, Ord)++instance Binary a => Binary (Document a) where+ put (Document t u c) = put t >> put u >> put c+ get = liftM3 Document get get get++instance XmlPickler a => XmlPickler (Document a) where+ xpickle = xpWrap ( \ (t, u, i) -> Document t u i+ , \ (Document t u i) -> (t, u, i)+ ) (xpTriple xpTitle xpURI xpickle)+ where+ xpURI = xpAttr "href" xpText0+ xpTitle = xpAttr "title" xpText0++instance NFData a => NFData (Document a) where+ rnf (Document t u c) = rnf t `seq` rnf u `seq` rnf c++-- ------------------------------------------------------------
+ src/Holumbus/Index/Common/LoadStore.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.LoadStore+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, UweSchmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ Load and store indexes++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.LoadStore+where++import Data.Binary ( Binary (..) )+import qualified+ Data.Binary as B++import qualified+ Data.List as L++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | Try to determine the file type automatically. The file is loaded as XML if the filename+-- ends with \".xml\" and otherwise is loaded as binary file.++loadFromFile :: (XmlPickler a, Binary a) => FilePath -> IO a+loadFromFile f = if L.isSuffixOf ".xml" f then loadFromXmlFile f else loadFromBinFile f+ +-- | Load from XML file.++loadFromXmlFile :: XmlPickler a => FilePath -> IO a+loadFromXmlFile f = do+ r <- runX (xunpickleDocument xpickle options f)+ return $! head r+ where+ options = [ withRemoveWS yes, withInputEncoding utf8, withValidate no ] ++-- | Write to XML file.++writeToXmlFile :: XmlPickler a => FilePath -> a -> IO ()+writeToXmlFile f i = do+ runX (constA i >>> xpickleDocument xpickle options f)+ >> return ()+ where+ options = [ withIndent yes, withOutputEncoding utf8 ]++-- | Load from a binary file.++loadFromBinFile :: Binary a => FilePath -> IO a+loadFromBinFile = B.decodeFile++-- | Write to a binary file.++writeToBinFile :: Binary a => FilePath -> a -> IO ()+writeToBinFile = B.encodeFile++-- ------------------------------------------------------------
+ src/Holumbus/Index/Common/Occurences.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.Occurences+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ The Occurences data type++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.Occurences+where++import Control.DeepSeq++import Data.Binary ( Binary (..) )+import qualified+ Data.Binary as B++import qualified Data.EnumMap as IM+import qualified Data.EnumSet as IS++import Holumbus.Index.Common.BasicTypes+import Holumbus.Index.Common.DocId+import Holumbus.Index.Common.DocIdMap++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | The occurrences in a number of documents.+-- A mapping from document ids to the positions in the document.++type Occurrences = DocIdMap Positions++-- | Create an empty set of positions.+emptyOccurrences :: Occurrences+emptyOccurrences = IM.empty++-- | Create an empty set of positions.+singletonOccurrence :: DocId -> Position -> Occurrences+singletonOccurrence d p = insertOccurrence d p IM.empty++-- | Test on empty set of positions.+nullOccurrences :: Occurrences -> Bool+nullOccurrences = IM.null++-- | Determine the number of positions in a set of occurrences.+sizeOccurrences :: Occurrences -> Int+sizeOccurrences = IM.fold ((+) . IS.size) 0++insertOccurrence :: DocId -> Position -> Occurrences -> Occurrences+insertOccurrence d p = IM.insertWith IS.union d (singletonPos p)++deleteOccurrence :: DocId -> Position -> Occurrences -> Occurrences+deleteOccurrence d p = substractOccurrences (IM.singleton d (singletonPos p))++updateOccurrences :: (DocId -> DocId) -> Occurrences -> Occurrences+updateOccurrences f = IM.foldWithKey (\ d ps res -> IM.insertWith IS.union (f d) ps res) emptyOccurrences++-- | Merge two occurrences.+mergeOccurrences :: Occurrences -> Occurrences -> Occurrences+mergeOccurrences = IM.unionWith IS.union++diffOccurrences :: Occurrences -> Occurrences -> Occurrences+diffOccurrences = IM.difference++-- | Substract occurrences from some other occurrences.+substractOccurrences :: Occurrences -> Occurrences -> Occurrences+substractOccurrences = IM.differenceWith substractPositions+ where+ substractPositions p1 p2+ = if IS.null diffPos+ then Nothing+ else Just diffPos+ where+ diffPos = IS.difference p1 p2++-- | The XML pickler for the occurrences of a word.++xpOccurrences :: PU Occurrences+xpOccurrences = xpWrap (IM.fromList, IM.toList)+ (xpList xpOccurrence)+ where+ xpOccurrence = xpElem "doc" $+ xpPair (xpAttr "idref" xpDocId)+ xpPositions++-- ------------------------------------------------------------++-- | The positions of the word in the document.+type Positions = IS.EnumSet Position++emptyPos :: Positions+emptyPos = IS.empty++singletonPos :: Position -> Positions+singletonPos = IS.singleton++memberPos :: Position -> Positions -> Bool+memberPos = IS.member++toAscListPos :: Positions -> [Position]+toAscListPos = IS.toAscList++fromListPos :: [Position] -> Positions+fromListPos = IS.fromList++sizePos :: Positions -> Int+sizePos = IS.size++unionPos :: Positions -> Positions -> Positions+unionPos = IS.union++foldPos :: (Position -> r -> r) -> r -> Positions -> r+foldPos = IS.fold++-- | The XML pickler for a set of positions.+xpPositions :: PU Positions+xpPositions = xpWrap ( IS.fromList . (map read) . words+ , unwords . (map show) . IS.toList+ ) xpText++instance (NFData v, Enum v) => NFData (IS.EnumSet v) where+ rnf = rnf . IS.toList++instance (Binary v, Enum v) => Binary (IS.EnumSet v) where+ put = B.put . IS.toList+ get = B.get >>= return . IS.fromList++-- ------------------------------------------------------------+
+ src/Holumbus/Index/Common/RawResult.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS #-} {-XMultiParamTypeClasses -XFlexibleContexts -XFlexibleInstances -XGeneralizedNewtypeDeriving -XTypeSynonymInstances -fno-warn-orphans #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Common.RawResult+ Copyright : Copyright (C) 2011 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: none portable++ The RawResult data type++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Common.RawResult+where++import qualified Data.EnumMap as IM++import Data.Map (Map)+import qualified Data.Map as M++import Holumbus.Index.Common.BasicTypes+import Holumbus.Index.Common.DocIdMap+import Holumbus.Index.Common.Occurences++-- ------------------------------------------------------------++-- | The raw result returned when searching the index.++type RawResult = [(Word, Occurrences)]++-- | Transform the raw result into a tree structure ordered by word.++resultByWord :: Context -> RawResult -> Map Word (Map Context Occurrences)+resultByWord c+ = M.fromList . map (\ (w, o) -> (w, M.singleton c o))++-- | Transform the raw result into a tree structure ordered by document.++resultByDocument :: Context -> RawResult -> DocIdMap (Map Context (Map Word Positions))+resultByDocument c os+ = mapDocIdMap transform $+ IM.unionsWith (flip $ (:) . head) (map insertWords os)+ where+ insertWords (w, o) = mapDocIdMap (\p -> [(w, p)]) o + transform w = M.singleton c (M.fromList w)++-- ------------------------------------------------------------+
+ src/Holumbus/Index/CompactDocuments.hs view
@@ -0,0 +1,313 @@+{-# OPTIONS -XFlexibleInstances -XMultiParamTypeClasses #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.CompactDocuments+ Copyright : Copyright (C) 2007- Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: MultiParamTypeClasses FlexibleInstances++ A more space efficient substitute for Holumbus.Index.Documents+-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.CompactDocuments +(+ -- * Documents type+ Documents (..)+ , CompressedDoc(..)+ , DocMap+ , URIMap++ -- * Construction+ , emptyDocuments+ , singleton+ + -- * Conversion+ , simplify+ , toDocument+ , fromDocument+ , fromDocMap+ , toDocMap+)+where++import qualified Codec.Compression.BZip as BZ++import Control.DeepSeq++import Data.Binary ( Binary )+import qualified Data.Binary as B+import Data.ByteString.Lazy ( ByteString )+import qualified Data.ByteString.Lazy as BS+import Data.Maybe ( fromJust )++import qualified Holumbus.Data.PrefixTree as M+import Holumbus.Index.Common++import Text.XML.HXT.Core++-- ----------------------------------------------------------------------------++-- | The table which is used to map a document to an artificial id and vice versa.++type URIMap = M.PrefixTree DocId+type DocMap a = DocIdMap (CompressedDoc a)++newtype CompressedDoc a = CDoc { unCDoc :: ByteString }+ deriving (Eq, Show)++data Documents a = Documents+ { idToDoc :: ! (DocMap a) -- ^ A mapping from a document id to+ -- the document itself.+ , docToId :: ! URIMap -- ^ A space efficient mapping from+ -- the URI of a document to its id.+ , lastDocId :: ! DocId -- ^ The last used document id.+ }+ deriving (Show)++-- ----------------------------------------------------------------------------++instance (Binary a, HolIndex i) => HolDocIndex Documents a i where+ defragmentDocIndex dt ix = (dt1, ix1)+ where+ dt1 = editDocIds editId dt+ ix1 = updateDocIds' editId ix+ editId i = fromJust . lookupDocIdMap i $ idMap+ idMap = fromListDocIdMap . flip zip (map mkDocId [1..]) . keysDocIdMap . toMap $ dt++ unionDocIndex dt1 ix1 dt2 ix2+ | s1 == 0 = (dt2, ix2)+ | s2 == 0 = (dt1, ix1)+ | s1 < s2 = unionDocIndex dt2 ix2 dt1 ix1+ | otherwise = (dt, ix)+ where+ dt = unionDocs dt1 dt2s+ ix = mergeIndexes ix1 ix2s++ dt2s = editDocIds add1 dt2+ ix2s = updateDocIds' add1 ix2++ add1 = mkDocId . (+ disp) . theDocId+ max1 = maxKeyDocIdMap . toMap $ dt1+ min2 = minKeyDocIdMap . toMap $ dt2+ disp = theDocId max1 + 1 - theDocId min2++ s1 = sizeDocs dt1+ s2 = sizeDocs dt2++-- ----------------------------------------------------------------------------++toDocument :: (Binary a) => CompressedDoc a -> Document a+toDocument = B.decode . BZ.decompress . unCDoc++fromDocument :: (Binary a) => Document a -> CompressedDoc a+fromDocument = CDoc . BZ.compress . B.encode++mapDocument :: (Binary a) => (Document a -> Document a) -> CompressedDoc a -> CompressedDoc a+mapDocument f = fromDocument . f . toDocument++toDocMap :: (Binary a) => DocIdMap (Document a) -> DocMap a+toDocMap = mapDocIdMap fromDocument++fromDocMap :: (Binary a) => DocMap a -> DocIdMap (Document a)+fromDocMap = mapDocIdMap toDocument++-- ----------------------------------------------------------------------------++instance Binary a => HolDocuments Documents a where+ sizeDocs d = sizeDocIdMap (idToDoc d)+ + lookupById d i = maybe (fail "") return+ . fmap toDocument+ . lookupDocIdMap i+ $ idToDoc d+ lookupByURI d u = maybe (fail "") return+ . M.lookup u+ $ docToId d++ -- this is a sufficient test, but if the doc ids don't form an intervall+ -- it may be too restrictive++ disjointDocs dt1 dt2+ | nullDocs dt1+ ||+ nullDocs dt2 = True+ | otherwise = disjoint ( minKeyDocIdMap . idToDoc $ dt1+ , maxKeyDocIdMap . idToDoc $ dt1+ )+ ( minKeyDocIdMap . idToDoc $ dt2+ , maxKeyDocIdMap . idToDoc $ dt2+ )+ where+ disjoint p1@(x1, y1) p2@(x2, _y2)+ | x1 <= x2 = y1 < x2+ | otherwise = disjoint p2 p1++ unionDocs dt1 dt2+ | disjointDocs dt1 dt2 = Documents+ { idToDoc = unionDocIdMap (idToDoc dt1) (idToDoc dt2)+ , docToId = M.union (docToId dt1) (docToId dt2)+ , lastDocId = lastDocId dt1 `max` lastDocId dt2+ }+ | otherwise = error $+ "unionDocs: doctables are not disjoint: " +++ show (didIntervall dt1) ++ ", " ++ show (didIntervall dt2)+ where+ didIntervall dt = ( minKeyDocIdMap . idToDoc $ dt+ , maxKeyDocIdMap . idToDoc $ dt+ )++ makeEmpty _ = emptyDocuments++ insertDoc ds d = maybe reallyInsert (\oldId -> (oldId, ds)) (lookupByURI ds (uri d))+ where+ reallyInsert = (newId, Documents newIdToDoc newDocToId newId)+ where+ newIdToDoc = insertDocIdMap newId (fromDocument d) (idToDoc ds)+ newDocToId = M.insert (uri d) newId (docToId ds)+ newId = incrDocId (lastDocId ds)++ updateDoc ds i d = ds + { idToDoc = insertDocIdMap i (fromDocument d) (idToDoc ds)+ , docToId = M.insert (uri d) i (docToId (removeById ds i))+ }++ removeById ds d = maybe ds reallyRemove (lookupById ds d)+ where+ reallyRemove (Document _ u _)+ = Documents+ (deleteDocIdMap d (idToDoc ds))+ (M.delete u (docToId ds))+ (lastDocId ds)++ updateDocuments f d = Documents updated (idToDoc2docToId updated) (lastId updated)+ where+ updated = mapDocIdMap (mapDocument f) (idToDoc d)++ filterDocuments p d = Documents filtered (idToDoc2docToId filtered) (lastId filtered)+ where + filtered = filterDocIdMap (p . toDocument) (idToDoc d) ++ fromMap itd' = Documents itd (idToDoc2docToId itd) (lastId itd)+ where+ itd = toDocMap itd'++ toMap = fromDocMap . idToDoc++ editDocIds f d = Documents+ { idToDoc = newIdToDoc+ , docToId = M.map f $ docToId d+ , lastDocId = lastId newIdToDoc+ }+ where+ newIdToDoc = foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap+ $ idToDoc d++-- ------------------------------------------------------------++-- Ignoring last document id when testing for equality++instance Eq a => Eq (Documents a)+ where+ (==) (Documents i2da d2ia _) (Documents i2db d2ib _)+ = (i2da == i2db)+ &&+ (d2ia == d2ib)++-- ----------------------------------------------------------------------------++instance NFData a => NFData (Documents a)+ where+ rnf (Documents i2d d2i lid) = rnf i2d `seq` rnf d2i `seq` rnf lid++-- ----------------------------------------------------------------------------++instance (Binary a, XmlPickler a) =>+ XmlPickler (Documents a)+ where+ xpickle = xpElem "documents" $+ xpWrap convertDoctable $+ xpWrap (fromListDocIdMap, toListDocIdMap) $+ xpList xpDocumentWithId+ where+ convertDoctable = ( \ itd -> Documents itd (idToDoc2docToId itd) (lastId itd)+ , \ (Documents itd _ _) -> itd+ )+ xpDocumentWithId = xpElem "doc" $+ xpPair (xpAttr "id" xpDocId) xpickle++-- ----------------------------------------------------------------------------++instance Binary a => Binary (Documents a)+ where+ put (Documents i2d _ lid) = B.put lid >> B.put i2d+ get = do lid <- B.get+ i2d <- B.get+ return (Documents i2d (idToDoc2docToId i2d) lid)++-- ------------------------------------------------------------++instance (Binary a, XmlPickler a) =>+ XmlPickler (CompressedDoc a)+ where+ xpickle = xpWrap (fromDocument , toDocument) $+ xpickle++-- ----------------------------------------------------------------------------++instance Binary a => Binary (CompressedDoc a)+ where+ put = B.put . unCDoc+ get = B.get >>= return . CDoc++-- ----------------------------------------------------------------------------++instance NFData (CompressedDoc a)+ where+ rnf (CDoc s) = BS.length s `seq` ()++-- ------------------------------------------------------------++-- | Create an empty table.++emptyDocuments :: Documents a+emptyDocuments = Documents emptyDocIdMap M.empty nullDocId++-- | Create a document table containing a single document.++singleton :: (Binary a) => Document a -> Documents a+singleton d = Documents+ (singletonDocIdMap firstDocId (fromDocument d))+ (M.singleton (uri d) firstDocId)+ firstDocId++-- | Simplify a document table by transforming the custom information into a string.++simplify :: (Binary a, Show a) => Documents a -> Documents String+simplify dt = Documents (simple (idToDoc dt)) (docToId dt) (lastDocId dt)+ where+ simple i2d = mapDocIdMap+ ( fromDocument+ . (\d -> Document (title d) (uri d) (maybe Nothing (Just . show) (custom d)))+ . toDocument+ ) i2d++-- | Construct the inverse map from the original map.++idToDoc2docToId :: Binary a => DocMap a -> URIMap+idToDoc2docToId = foldWithKeyDocIdMap+ (\i d r -> M.insert (uri . toDocument $ d) i r)+ M.empty++-- | Query the 'idToDoc' part of the document table for the last id.++lastId :: DocMap a -> DocId+lastId = maxKeyDocIdMap++-- ------------------------------------------------------------
+ src/Holumbus/Index/CompactIndex.hs view
@@ -0,0 +1,276 @@+{-# OPTIONS #-}++-- ------------------------------------------------------------++module Holumbus.Index.CompactIndex+ ( Document+ , Documents+ , SmallDocuments++ , Inverted+ , emptyInverted+ , removeDocIdsInverted++ , CompactInverted+ , emptyCompactInverted+ , inverted2compactInverted++ , HolumbusState+ , HolumbusConfig+ , emptyHolumbusState+ , defragmentHolumbusState++ , emptyIndexerState+ , emptyDocuments++ , emptySmallDocuments + , docTable2smallDocTable++ , mergeAndWritePartialRes'+ , writeXml+ , writeBin+ , writeSearchBin+ , writePartialIndex+ )+where++import Control.Arrow+import Control.DeepSeq+import Control.Monad.Reader++import Data.Binary++import Data.Function.Selector ( (.&&&.) )++import Holumbus.Crawler.Types+import Holumbus.Crawler.IndexerCore+import Holumbus.Crawler.Logger++import Holumbus.Index.Common ( Document(..)+ , Occurrences+ , defragmentDocIndex+ , fromList+ , toList+ , unionDocs+ , mergeIndexes+ )++import Holumbus.Index.CompactDocuments+ ( Documents(..)+ , emptyDocuments+ )++import Holumbus.Index.CompactSmallDocuments+ ( SmallDocuments(..)+ , docTable2smallDocTable+ )+import qualified Holumbus.Index.CompactSmallDocuments+ as CSD++import Text.XML.HXT.Core++-- ------------------------------------------------------------++{- .1: direct use of prefix tree with simple-9 encoded occurences++ concerning efficiency this implementation is about the same as the 2. one,+ space and time are minimally better, the reason could be less code working with classes++import Holumbus.Index.Inverted.PrefixMem++-- -}+-- ------------------------------------------------------------++{- .2: indirect use of prefix tree with simple-9 encoded occurences via InvertedCompressed++ minimal overhead compared to .1+ but less efficient in time (1598s / 1038s) and space+ total mem use (2612MB / 2498MB) than .3++import qualified Holumbus.Index.Inverted.CompressedPrefixMem as PM++type Inverted = PM.InvertedCompressed++emptyInverted :: Inverted+emptyInverted = PM.emptyInvertedCompressed++-- -}++-- ------------------------------------------------------------+-- {-++{- .3: indirect prefix tree without compression of position sets++ best of these 3 implementations++ implementations with serializations become much more inefficient+ in runtime and are not worth to be considered+-}++import qualified Holumbus.Index.Inverted.CompressedPrefixMem as PM++type Inverted = PM.Inverted0++emptyInverted :: Inverted+emptyInverted = PM.emptyInverted0++removeDocIdsInverted :: Occurrences -> Inverted -> Inverted+removeDocIdsInverted = PM.removeDocIdsInverted++type CompactInverted = PM.InvertedOSerialized++emptyCompactInverted :: CompactInverted+emptyCompactInverted = PM.emptyInvertedOSerialized++inverted2compactInverted :: Inverted -> CompactInverted+inverted2compactInverted = fromList PM.emptyInvertedOSerialized . toList++-- -}+-- ------------------------------------------------------------++type HolumbusState di = IndexerState Inverted Documents di+type HolumbusConfig di = IndexCrawlerConfig Inverted Documents di++emptyHolumbusState :: HolumbusState di+emptyHolumbusState = emptyIndexerState emptyInverted emptyDocuments++flushHolumbusState :: HolumbusState di -> HolumbusState di+flushHolumbusState hs = hs { ixs_index = emptyInverted+ , ixs_documents = emptyDocuments+ { lastDocId = lastDocId . ixs_documents $ hs }+ }++emptySmallDocuments :: SmallDocuments a+emptySmallDocuments = CSD.emptyDocuments++-- ------------------------------------------------------------++defragmentHolumbusState :: (Binary di) =>+ HolumbusState di -> HolumbusState di+defragmentHolumbusState IndexerState+ { ixs_index = ix+ , ixs_documents = dt+ } = IndexerState+ { ixs_index = ix'+ , ixs_documents = dt'+ }+ where+ (dt', ix') = defragmentDocIndex dt ix++-- ------------------------------------------------------------++mergeAndWritePartialRes' :: (MonadIO m, NFData i, Binary i) =>+ (SmallDocuments i -> SmallDocuments i) -> [String] -> String -> m ()+mergeAndWritePartialRes' id' pxs out+ = do notice $ ["merge partial doctables from"] ++ pxs+ mdocs <- mergeSmallDocs $ map (++ ".doc") pxs+ notice $ ["write merged doctable to", out ++ ".doc"]+ liftIO $ encodeFile (out ++ ".doc") (id' mdocs)+ notice $ ["merge partial indexes from"] ++ pxs+ mixs <- mergeCompactIxs $ map (++ ".idx") pxs+ notice $ ["write merged indexes to", out ++ ".idx"]+ liftIO $ encodeFile (out ++ ".idx") mixs+ notice $ ["merge partial doctables and indexes done"]++mergeSmallDocs :: (MonadIO m, NFData i, Binary i) => [String] -> m (SmallDocuments i)+mergeSmallDocs []+ = return emptySmallDocuments+mergeSmallDocs (x : xs)+ = do docs <- mergeSmallDocs xs+ notice ["merge small documents from file", x]+ doc1 <- liftIO $ decodeFile x+ rnf doc1 `seq`+ (return $ unionDocs docs doc1)++mergeCompactIxs :: (MonadIO m) => [String] -> m CompactInverted+mergeCompactIxs []+ = return emptyCompactInverted+mergeCompactIxs (x : xs)+ = do ixs <- mergeCompactIxs xs+ notice ["merge compact index from file", x]+ ix1 <- liftIO $ decodeFile x+ rnf ix1 `seq`+ (return $ mergeIndexes ix1 ixs)++-- ------------------------------------------------------------++writeXml :: (MonadIO m, XmlPickler a) => FilePath -> a -> m ()+writeXml xf v+ | xmlOut+ = do notice ["writing into XML file", xmlFile]+ liftIO $ runX (constA v+ >>> hxtSetTraceAndErrorLogger WARNING+ >>> xpickleDocument xpickle [withIndent yes] xmlFile+ )+ >> return ()+ notice ["writing XML finished"]+ | otherwise+ = notice ["no XML output"]+ where+ (xmlOut, xmlFile)+ | null xf = (False, xf)+ | xf == "-" = (True, "")+ | otherwise = (True, xf)++writeBin :: (MonadIO m, Binary a) => FilePath -> a -> m ()+writeBin out v+ | null out+ = notice ["no binary output"]+ | otherwise+ = do notice ["writing into binary file", out]+ liftIO $ encodeFile out v+ notice ["writing binary data finished"]++writeSearchBin :: (Binary c, MonadIO m) => FilePath -> HolumbusState c -> m ()+writeSearchBin out state+ | null out+ = notice ["no search index written"]+ | otherwise+ = do notice ["writing small document table into binary file", docFile]+ liftIO $ encodeFile docFile (docTable2smallDocTable . ixs_documents $ state)+ notice ["writing compressed inverted index into binary file", idxFile]+ liftIO $ encodeFile idxFile (inverted2compactInverted . ixs_index $ state)+ notice ["writing search index files finished"]+ where+ docFile = out ++ ".doc"+ idxFile = out ++ ".idx"++-- ------------------------------------------------------------++writePartialIndex :: (NFData c, XmlPickler c, Binary c) =>+ Bool -> FilePath -> CrawlerAction a (HolumbusState c) ()+writePartialIndex xout fn+ = modifyStateIO+ (theResultAccu .&&&. theResultInit)+ (\ (r, _i) -> do r' <- writePartialIndex' xout fn r+ return (r', r')+ )++{- the above code is a bit tricky:+ when crawling is done in parallel, then initial result is used as a unit value,+ when merging results. When a partial index is written out, the document id count+ must not be set back to its initial value, to avoid renumbering when merging then+ partial indexes. As a consequence, not only the result accu must be changed+ but also the initial value.++ When this is not done, the indexer runs fine when using the sequential merge,+ but when running the parallel one, the index ids will overlap.+-}++writePartialIndex' :: (NFData c, XmlPickler c, Binary c) =>+ Bool -> FilePath -> HolumbusState c -> IO (HolumbusState c)+writePartialIndex' xout out ixs+ = do writeSearchBin out ixs+ if xout+ then writeXml (out ++ ".xml") ixs+ else return ()+ let ixs' = flushHolumbusState ixs+ rnf ixs' `seq`+ return ixs'++-- ------------------------------------------------------------++notice :: MonadIO m => [String] -> m ()+notice = noticeC "compactIndex"++-- ------------------------------------------------------------
+ src/Holumbus/Index/CompactSmallDocuments.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS -XFlexibleInstances -XMultiParamTypeClasses #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.CompactDocuments+ Copyright : Copyright (C) 2007-2010 Sebastian M. Schlatt, Timo B. Huebel+ License : MIT++ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: MultiParamTypeClasses FlexibleInstances++ A simple version of Holumbus.Index.Documents.+ This implementation is only for reading a document table in the search part of an application.+ The mapping of URIs to DocIds is only required during index building, not when accessing the index.+ So this 2. mapping is removed in this implementation for saving space+-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.CompactSmallDocuments +(+ -- * Documents type+ SmallDocuments (..)++ -- * Construction+ , emptyDocuments+ , singleton++ -- * Conversion+ , docTable2smallDocTable+)+where++import Control.DeepSeq++import Data.Binary ( Binary )+import qualified Data.Binary as B++import Holumbus.Index.Common+import qualified Holumbus.Index.CompactDocuments as CD++import Text.XML.HXT.Core++-- ----------------------------------------------------------------------------++-- | The table to store the document descriptions+--+-- This table does not contain the reverse map from URIs do DocIds,+-- this reverse map is only needed when crawling, not for searching the index.+-- As a consequence, most of the indes operations are not implemented+--+-- see also 'Holumbus.Index.CompactDocuments.Documents' data type++newtype SmallDocuments a = SmallDocuments+ { idToSmallDoc :: CD.DocMap a -- ^ A mapping from a doc id+ -- to the document itself.+ }++-- ----------------------------------------------------------------------------++instance (Binary a, HolIndex i) => HolDocIndex SmallDocuments a i where+ defragmentDocIndex = notImpl+{-+ defragmentDocIndex dt ix = (dt1, ix1)+ where+ dt1 = editDocIds editId dt+ ix1 = updateDocIds' editId ix+ editId i = fromJust . lookupDocIdMap i $ idMap+ idMap = fromListDocIdMap . flip zip (map mkDocId [1..]) . keysDocIdMap . toMap $ dt+-}++ unionDocIndex dt1 ix1 dt2 ix2+ = (dt, ix)+ where+ dt = unionDocs dt1 dt2+ ix = mergeIndexes ix1 ix2++-- ----------------------------------------------------------------------------++instance Binary a => HolDocuments SmallDocuments a where+ sizeDocs = sizeDocIdMap . idToSmallDoc+ + lookupById d i = maybe (fail "") return+ . fmap CD.toDocument+ . lookupDocIdMap i+ . idToSmallDoc+ $ d++ makeEmpty _ = emptyDocuments++ -- this is a sufficient test, but if the doc ids don't form an intervall+ -- it may be too strict++ disjointDocs dt1 dt2+ | nullDocs dt1+ ||+ nullDocs dt2 = True+ | otherwise = disjoint ( minKeyDocIdMap . idToSmallDoc $ dt1+ , maxKeyDocIdMap . idToSmallDoc $ dt1+ )+ ( minKeyDocIdMap . idToSmallDoc $ dt2+ , maxKeyDocIdMap . idToSmallDoc $ dt2+ )+ where+ disjoint p1@(x1, y1) p2@(x2, _y2)+ | x1 <= x2 = y1 < x2+ | otherwise = disjoint p2 p1++ unionDocs dt1 dt2+ | disjointDocs dt1 dt2 = SmallDocuments+ { idToSmallDoc = unionDocIdMap (idToSmallDoc dt1) (idToSmallDoc dt2)+ }+ | otherwise = error $+ "unionDocs: doctables are not disjoint: " +++ show (didIntervall dt1) ++ ", " ++ show (didIntervall dt2)+ where+ didIntervall dt = ( minKeyDocIdMap . idToSmallDoc $ dt+ , maxKeyDocIdMap . idToSmallDoc $ dt+ )++ editDocIds f d = SmallDocuments+ { idToSmallDoc = newIdToDoc+ }+ where+ newIdToDoc = foldWithKeyDocIdMap (insertDocIdMap . f) emptyDocIdMap+ $ idToSmallDoc d++ fromMap = SmallDocuments . CD.toDocMap+ toMap = CD.fromDocMap . idToSmallDoc++ -- only lookup by doc id, union and defragment ops are implemented+ -- the others are not needed when merging or searching the doc indexes++ lookupByURI = notImpl++ insertDoc = notImpl+ updateDoc = notImpl+ removeById = notImpl+ updateDocuments = notImpl+ filterDocuments = notImpl++-- ----------------------------------------------------------------------------++instance NFData a => NFData (SmallDocuments a)+ where+ rnf (SmallDocuments i2d) = rnf i2d++-- ----------------------------------------------------------------------------++instance (Binary a, XmlPickler a) =>+ XmlPickler (SmallDocuments a)+ where+ xpickle = xpElem "documents" $+ xpWrap convertDoctable $+ xpWrap (fromListDocIdMap, toListDocIdMap) $+ xpList xpDocumentWithId+ where+ convertDoctable = ( SmallDocuments+ , idToSmallDoc+ )+ xpDocumentWithId = xpElem "doc" $+ xpPair (xpAttr "id" xpDocId) xpickle++-- ----------------------------------------------------------------------------++instance Binary a => Binary (SmallDocuments a)+ where+ put (SmallDocuments i2d) = B.put i2d+ get = do+ i2d <- B.get+ return $ SmallDocuments i2d++-- ------------------------------------------------------------++notImpl :: a+notImpl = error "operation not implemented for SmallDocuments data type"++-- ------------------------------------------------------------++-- | Create an empty table.++emptyDocuments :: SmallDocuments a+emptyDocuments = SmallDocuments emptyDocIdMap++-- | Create a document table containing a single document.++singleton :: (Binary a) => Document a -> SmallDocuments a+singleton d = SmallDocuments (singletonDocIdMap firstDocId (CD.fromDocument d))++-- | Convert a Compact document table into a small compact document table.+-- Called at the end of building an index++docTable2smallDocTable :: CD.Documents a -> SmallDocuments a+docTable2smallDocTable = SmallDocuments . CD.idToDoc++-- ------------------------------------------------------------
+ src/Holumbus/Index/Compression.hs view
@@ -0,0 +1,68 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Compression+ Copyright : Copyright (C) 2008 Timo B. Huebel+ License : MIT+ + Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.1+ + This module provides several specific compression mechanisms for different+ parts of indexes. Right now, just a general compression scheme for + the 'Occurrences' and 'Positions' are provided.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Index.Compression + (+ -- * Compression types+ CompressedOccurrences+ , CompressedPositions+ + -- * Compress+ , deflateOcc+ , deflatePos+ + -- * Decompress+ , inflateOcc+ , inflatePos+ )+where++import Holumbus.Index.Common.DocIdMap+import Holumbus.Index.Common.Occurences+import Holumbus.Index.Common.DiffList++-- ----------------------------------------------------------------------------++type CompressedOccurrences = DocIdMap CompressedPositions+type CompressedPositions = DiffList++-- ----------------------------------------------------------------------------++-- | Decompressing the occurrences by just decompressing all contained positions.++inflateOcc :: CompressedOccurrences -> Occurrences+inflateOcc = mapDocIdMap inflatePos++-- | Compress the occurrences by just compressing all contained positions.++deflateOcc :: Occurrences -> CompressedOccurrences+deflateOcc = mapDocIdMap deflatePos++-- | Convert the compressed differences back to a set of integers.++inflatePos :: CompressedPositions -> Positions+inflatePos = toPositions++-- | Save some memory on the positions by just saving their differences and compressing these.++deflatePos :: Positions -> CompressedPositions+deflatePos = fromPositions++-- ----------------------------------------------------------------------------
+ src/Holumbus/Index/Inverted/CompressedPrefixMem.hs view
@@ -0,0 +1,464 @@+module Holumbus.Index.Inverted.CompressedPrefixMem+ ( Inverted(..)+ , Parts+ , Part+ , Inverted0+ , InvertedCompressed+ , InvertedSerialized+ , InvertedCSerialized+ , InvertedOSerialized++ , ComprOccurrences(..)++ , emptyInverted0+ , emptyInvertedCompressed+ , emptyInvertedSerialized+ , emptyInvertedCSerialized+ , emptyInvertedOSerialized++ , Sizeof(..)+ , sizeofAttrsInverted++ , mapOcc+ , zipOcc+ , emptyOcc+ , theOcc+ , nullOcc+ , unionOcc+ , diffOcc+ , insertPosOcc+ , deletePosOcc+ , updateDocIdOcc+ , deleteDocIds++ , removeDocIdsInverted+ )+where++import qualified Codec.Compression.BZip as BZ++import Control.DeepSeq++import qualified Data.ByteString.Lazy as BS+import qualified Data.Binary as B++import Data.Function ( on )++import Data.Int++import Data.List ( foldl', sortBy )+import qualified Data.Map as M+import Data.Maybe++import Holumbus.Index.Common+import Holumbus.Index.Compression++import qualified Holumbus.Data.PrefixTree as PT++import Text.XML.HXT.Core++-- ----------------------------------------------------------------------------++class ComprOccurrences s where+ toOccurrences :: s -> Occurrences+ fromOccurrences :: Occurrences -> s++mapOcc :: (ComprOccurrences s) => (Occurrences -> Occurrences) -> s -> s+mapOcc f = fromOccurrences . f . toOccurrences++zipOcc :: (ComprOccurrences s) => (Occurrences -> Occurrences -> Occurrences) -> s -> s -> s+zipOcc op x y = fromOccurrences $ op (toOccurrences x)(toOccurrences y)++emptyOcc :: (ComprOccurrences s) => s+emptyOcc = fromOccurrences $ emptyOccurrences++theOcc :: (ComprOccurrences s) => s -> Occurrences+theOcc = toOccurrences++nullOcc :: (ComprOccurrences s) => s -> Bool+nullOcc = (== emptyOccurrences) . toOccurrences -- better nullOccurrences, but not yet there++unionOcc :: (ComprOccurrences s) => Occurrences -> s -> s+unionOcc os = mapOcc $ mergeOccurrences os++diffOcc :: (ComprOccurrences s) => Occurrences -> s -> s+diffOcc os = mapOcc $ substractOccurrences os++insertPosOcc :: (ComprOccurrences s) => DocId -> Position -> s -> s+insertPosOcc d p = mapOcc $ insertOccurrence d p++deletePosOcc :: (ComprOccurrences s) => DocId -> Position -> s -> s+deletePosOcc d p = mapOcc $ deleteOccurrence d p++updateDocIdOcc :: (ComprOccurrences s) => (DocId -> DocId) -> s -> s+updateDocIdOcc f = mapOcc $ updateOccurrences f++deleteDocIds :: (ComprOccurrences s) => Occurrences -> s -> s+deleteDocIds ids = mapOcc $ flip diffOccurrences ids++-- ----------------------------------------------------------------------------+--+-- overloaded function sizeof for estimating the size of a value++class Sizeof a where+ sizeof :: a -> Int64++-- ----------------------------------------------------------------------------+--+-- auxiliary types++newtype ByteString = Bs { unBs :: BS.ByteString }+ deriving (Eq, Show)++instance NFData ByteString where+ rnf s = BS.length (unBs s) `seq` ()++instance B.Binary ByteString where+ put = B.put . unBs+ get = B.get >>= return . Bs++instance Sizeof ByteString where+ sizeof = (8 + ) . BS.length . unBs -- we need the size of the length + the length++-- ----------------------------------------------------------------------------+--+-- the pure occurrence type, just wrapped in a newtype for instance declarations++newtype Occ0 = Occ0 { unOcc0 :: Occurrences }++instance ComprOccurrences Occ0 where+ fromOccurrences = Occ0+ toOccurrences = unOcc0++instance NFData Occ0 where+ rnf = rnf . unOcc0++instance B.Binary Occ0 where+ put = B.put . unOcc0+ get = B.get >>= return . Occ0++instance Sizeof Occ0 where+ sizeof = BS.length . B.encode . unOcc0++-- ----------------------------------------------------------------------------+--+-- the simple-9 compressed occurrence type, just wrapped in a newtype for instance declarations++newtype OccCompressed = OccCp { unOccCp :: CompressedOccurrences }+ deriving (Eq, Show)++instance ComprOccurrences OccCompressed where+ fromOccurrences = OccCp . deflateOcc+ toOccurrences = inflateOcc . unOccCp++instance NFData OccCompressed where+ rnf = rnf . unOccCp++instance B.Binary OccCompressed where+ put = B.put . unOccCp+ get = B.get >>= return . OccCp++instance Sizeof OccCompressed where+ sizeof = BS.length . B.encode . unOccCp++-- ----------------------------------------------------------------------------+--+-- the simpe-9 compresses occurrences serialized into a byte strings++newtype OccSerialized = OccBs { unOccBs :: ByteString }+ deriving (Eq, Show)++instance ComprOccurrences OccSerialized where+ fromOccurrences = OccBs . Bs . B.encode . deflateOcc+ toOccurrences = inflateOcc . B.decode . unBs . unOccBs++instance NFData OccSerialized where+ rnf = rnf . unOccBs++instance B.Binary OccSerialized where+ put = B.put . unOccBs+ get = B.get >>= return . OccBs++instance Sizeof OccSerialized where+ sizeof = sizeof . unOccBs++-- ----------------------------------------------------------------------------+--+-- the simple-9 compressed occurrences serialized and bzipped into a byte string++newtype OccCSerialized = OccCBs { unOccCBs :: ByteString }+ deriving (Eq, Show)++instance ComprOccurrences OccCSerialized where+ fromOccurrences = OccCBs . Bs . BZ.compress . B.encode . deflateOcc+ toOccurrences = inflateOcc . B.decode . BZ.decompress . unBs . unOccCBs++instance NFData OccCSerialized where+ rnf = rnf . unOccCBs++instance B.Binary OccCSerialized where+ put = B.put . unOccCBs+ get = B.get >>= return . OccCBs++instance Sizeof OccCSerialized where+ sizeof = sizeof . unOccCBs++-- ----------------------------------------------------------------------------+--+-- the pure occurrences serialized and bzipped into a byte string+-- this seems to be the best choice: compression is about 4% better then simple-9 & bzip+-- and lookup is about 8% better++newtype OccOSerialized = OccOBs { unOccOBs :: ByteString }+ deriving (Eq, Show)++instance ComprOccurrences OccOSerialized where+ fromOccurrences = OccOBs . Bs . BZ.compress . B.encode+ toOccurrences = B.decode . BZ.decompress . unBs . unOccOBs++instance NFData OccOSerialized where+ rnf = rnf . unOccOBs++instance B.Binary OccOSerialized where+ put = B.put . unOccOBs+ get = B.get >>= return . OccOBs++instance Sizeof OccOSerialized where+ sizeof = sizeof . unOccOBs++-- ----------------------------------------------------------------------------++-- | The index consists of a table which maps documents to ids and a number of index parts.++newtype Inverted occ = Inverted+ { unInverted :: Parts occ -- ^ The parts of the index, each representing one context.+ } + deriving (Show, Eq)++-- | The index parts are identified by a name, which should denote the context of the words.++type Parts occ = M.Map Context (Part occ)++-- | The index part is the real inverted index. Words are mapped to their occurrences.+-- The part is implemented as a prefix tree++type Part occ = PT.PrefixTree occ++-- ----------------------------------------------------------------------------++instance (NFData occ) => NFData (Inverted occ) where+ rnf = rnf . unInverted++-- ----------------------------------------------------------------------------++instance (ComprOccurrences occ) => XmlPickler (Inverted occ) where+ xpickle = xpElem "indexes" $+ xpWrap (Inverted, unInverted) xpParts++xpParts :: (ComprOccurrences occ) => PU (Parts occ)+xpParts = xpWrap (M.fromList, M.toList) (xpList xpContext)+ where+ xpContext = xpElem "part" (xpPair (xpAttr "id" xpText) xpPart)++xpPart :: (ComprOccurrences occ) => PU (Part occ)+xpPart = xpElem "index" (xpWrap (PT.fromList, PT.toList) (xpList xpWord))+ where+ xpWord = xpElem "word" $+ xpPair (xpAttr "w" xpText)+ (xpWrap (fromOccurrences, toOccurrences) xpOccurrences)++-- ----------------------------------------------------------------------------++instance (B.Binary occ) => B.Binary (Inverted occ) where+ put = B.put . unInverted+ get = B.get >>= return . Inverted++-- ----------------------------------------------------------------------------++instance (B.Binary occ, ComprOccurrences occ) => HolIndex (Inverted occ) where+ sizeWords = M.fold ((+) . PT.size) 0 . unInverted+ contexts = fmap fst . M.toList . unInverted++ allWords i c = fmap (second toOccurrences) . PT.toList . getPart c $ i+ prefixCase i c q = fmap (second toOccurrences) . PT.prefixFindWithKeyBF q . getPart c $ i+ prefixNoCase i c q = fmap (second toOccurrences) . PT.prefixFindNoCaseWithKeyBF q . getPart c $ i+ lookupCase i c q = fmap ((,) q . toOccurrences) . maybeToList . PT.lookup q . getPart c $ i+ lookupNoCase i c q = fmap (second toOccurrences) . PT.lookupNoCase q . getPart c $ i++ mergeIndexes = zipInverted $ M.unionWith $ PT.unionWith (zipOcc mergeOccurrences)+ substractIndexes = zipInverted $ M.differenceWith $ substractPart++ insertOccurrences c w o i = mergeIndexes i (singletonInverted c w o) -- see "http://holumbus.fh-wedel.de/hayoo/hayoo.html#0:unionWith%20module%3AData.Map"+ deleteOccurrences c w o i = substractIndexes i (singletonInverted c w o)++ toList = concatMap (uncurry convertPart) . toListInverted+ where+ convertPart c = map (\(w, o) -> (c, w, toOccurrences o)) . PT.toList++ splitByContexts = splitInverted+ . map ( (\ i -> (sizeWords i, i))+ . Inverted+ . uncurry M.singleton+ )+ . toListInverted++ splitByDocuments i = splitInverted ( map (uncurry convert) $+ toListDocIdMap $+ unionsWithDocIdMap (M.unionWith (M.unionWith unionPos)) docResults+ )+ where+ docResults = map (\c -> resultByDocument c (allWords i c)) (contexts i)+ convert d cs = foldl' makeIndex (0, emptyInverted) (M.toList cs)+ where+ makeIndex r (c, ws) = foldl' makeOcc r (M.toList ws)+ where+ makeOcc (rs, ri) (w, p) = (sizePos p + rs, insertOccurrences c w (singletonDocIdMap d p) ri)++ splitByWords i = splitInverted ( map (uncurry convert) .+ M.toList .+ M.unionsWith (M.unionWith mergeOccurrences) $ wordResults+ )+ where+ wordResults = map (\c -> resultByWord c (allWords i c)) (contexts i)+ convert w cs = foldl' makeIndex (0, emptyInverted) (M.toList cs)+ where+ makeIndex (rs, ri) (c, o) = (rs + sizeOccurrences o, insertOccurrences c w o ri)++ updateDocIds f = mapInverted (M.mapWithKey updatePart)+ where+ updatePart c = PT.mapWithKey (updateOcc (f c))+ updateOcc f' w = mapOcc $ updateOccurrences (f' w)++-- ----------------------------------------------------------------------------++-- | Return a part of the index for a given context.++getPart :: Context -> Inverted i -> Part i+getPart c = fromMaybe PT.empty . M.lookup c . unInverted++-- | Substract one index part from another.+substractPart :: (ComprOccurrences i) => Part i -> Part i -> Maybe (Part i)+substractPart p1 p2+ | PT.null res = Nothing+ | otherwise = Just res+ where+ res = diffPart p1 p2++diffPart :: (ComprOccurrences i) => Part i -> Part i -> Part i+diffPart = PT.differenceWith subtractDiffLists+ where+ subtractDiffLists o1 o2+ | nullOcc res = Nothing+ | otherwise = Just res+ where+ res = zipOcc substractOccurrences o1 o2++removeDocIdsPart :: (ComprOccurrences i) => Occurrences -> Part i -> Part i+removeDocIdsPart ids = PT.foldWithKey removeDocIds PT.empty+ where+ removeDocIds k occ acc+ | nullOcc occ' = acc+ | otherwise = PT.insert k occ' acc+ where+ occ' = deleteDocIds ids occ++-- ----------------------------------------------------------------------------++mapInverted :: (Parts i -> Parts i) -> Inverted i -> Inverted i+mapInverted f = Inverted . f . unInverted++zipInverted :: (Parts i -> Parts i -> Parts i) -> Inverted i -> Inverted i -> Inverted i+zipInverted op i1 i2 = Inverted $ op (unInverted i1) (unInverted i2)++emptyInverted :: Inverted i+emptyInverted = Inverted M.empty++toListInverted :: Inverted i -> [(Context, Part i)]+toListInverted = M.toList . unInverted++-- | Create an index with just one word in one context.++singletonInverted :: (ComprOccurrences i) => Context -> String -> Occurrences -> Inverted i+singletonInverted c w o = Inverted . M.singleton c . PT.singleton w . fromOccurrences $ o++sizeofAttrsInverted :: (Sizeof i) => Inverted i -> Int64+sizeofAttrsInverted = M.fold ((+) . sizeofPT) 0 . unInverted+ where+ sizeofPT = PT.fold ((+) . sizeof) 0++-- | Remove DocIds from index++removeDocIdsInverted :: (ComprOccurrences i) => Occurrences -> Inverted i -> Inverted i+removeDocIdsInverted ids = mapInverted $ M.map (removeDocIdsPart ids)++-- ----------------------------------------------------------------------------+--+-- copied from Holumbus.Index.Inverted.Memory++splitInverted :: (B.Binary i, ComprOccurrences i) => [(Int, Inverted i)] -> Int -> [Inverted i]+splitInverted inp n = allocate mergeIndexes stack buckets+ where+ buckets = zipWith const (createBuckets n) stack+ stack = reverse (sortBy (compare `on` fst) inp)++-- | Allocates values from the first list to the buckets in the second list.+allocate :: (a -> a -> a) -> [(Int, a)] -> [(Int, a)] -> [a]+allocate _ _ [] = []+allocate _ [] ys = map snd ys+allocate f (x:xs) (y:ys) = allocate f xs (sortBy (compare `on` fst) ((combine x y):ys))+ where+ combine (s1, v1) (s2, v2) = (s1 + s2, f v1 v2)++-- | Create empty buckets for allocating indexes. +createBuckets :: Int -> [(Int, Inverted i)]+createBuckets n = (replicate n (0, emptyInverted))++-- ----------------------------------------------------------------------------+--+-- the 5 variants for the inverted index as prefix tree,++-- | The pure inverted index implemented as a prefix tree without any space optimizations.+-- This may be taken as a reference for space and time measurements for the other index structures+ +type Inverted0 = Inverted Occ0++-- | The inverted index with simple-9 encoding of the occurence sets++type InvertedCompressed = Inverted OccCompressed++-- | The inverted index with serialized occurence maps with simple-9 encoded sets++type InvertedSerialized = Inverted OccSerialized++-- | The inverted index with serialized occurence maps with simple-9 encoded sets+-- and with the serialized bytestrings compressed with bzip2++type InvertedCSerialized = Inverted OccCSerialized++-- | The pure inverted index with serialized occurence maps+-- and with the serialized bytestrings compressed with bzip2, no simple-9 encoding.+-- This is the most space efficient index of the 5 variants, even a few percent smaller+-- then InvertedCSerialized, and a few percent faster in lookup++type InvertedOSerialized = Inverted OccOSerialized++-- ----------------------------------------------------------------------------++emptyInverted0 :: Inverted0+emptyInverted0 = emptyInverted++emptyInvertedCompressed :: InvertedCompressed+emptyInvertedCompressed = emptyInverted++emptyInvertedSerialized :: InvertedSerialized+emptyInvertedSerialized = emptyInverted++emptyInvertedCSerialized :: InvertedCSerialized+emptyInvertedCSerialized = emptyInverted++emptyInvertedOSerialized :: InvertedOSerialized+emptyInvertedOSerialized = emptyInverted+++-- ----------------------------------------------------------------------------+
+ src/Holumbus/Index/Inverted/PrefixMem.hs view
@@ -0,0 +1,228 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Index.Inverted.PrefixMem+ Copyright : Copyright (C) 2007 - 2009 Sebastian M. Schlatt, Timo B. Huebel, Uwe Schmidt+ License : MIT+ + Maintainer : Uwe Schmidt (uwe@fh-wedel.de)+ Stability : experimental+ Portability: portable+ + A variant of the Inverted.Memory index with an optimized prefix tree+ instead of a trie as central data structure. This version should be+ more space efficient as the trie and more runtime efficient when combining+ whole indexes.++ For switching from Memory to this module, only the import has to be modified++-}++-- ----------------------------------------------------------------------------++{-# OPTIONS -XTypeSynonymInstances -XFlexibleInstances -XMultiParamTypeClasses #-}++module Holumbus.Index.Inverted.PrefixMem + (+ -- * Inverted index types+ Inverted (..)+ , Parts+ , Part+ + -- * Construction+ , singleton+ , emptyInverted+ )+where++import Control.DeepSeq++import Data.Binary hiding (Word)+import Data.Function+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe++import qualified Holumbus.Data.PrefixTree as PT++import Holumbus.Index.Common+import Holumbus.Index.Compression++import Text.XML.HXT.Core++-- ----------------------------------------------------------------------------++-- | The index consists of a table which maps documents to ids and a number of index parts.++newtype Inverted = Inverted { indexParts :: Parts } + deriving (Show, Eq)++-- | The index parts are identified by a name, which should denote the context of the words.++type Parts = Map Context Part++-- | The index part is the real inverted index. Words are mapped to their occurrences.++type Part = PT.PrefixTree CompressedOccurrences++-- ----------------------------------------------------------------------------++instance HolIndex Inverted where+ sizeWords = M.fold ((+) . PT.size) 0 . indexParts+ contexts = map fst . M.toList . indexParts++ allWords i c = map (\(w, o) -> (w, inflateOcc o)) $ PT.toList $ getPart c i+ prefixCase i c q = map (\(w, o) -> (w, inflateOcc o)) $ PT.prefixFindWithKey q $ getPart c i+ prefixNoCase i c q = map (\(w, o) -> (w, inflateOcc o)) $ PT.prefixFindNoCaseWithKey q $ getPart c i+ lookupCase i c q = map (\ o -> (q, inflateOcc o)) $ maybeToList (PT.lookup q $ getPart c i)+ lookupNoCase i c q = map (\(w, o) -> (w, inflateOcc o)) $ PT.lookupNoCase q $ getPart c i++ mergeIndexes i1 i2 = Inverted (mergeParts (indexParts i1) (indexParts i2))+ substractIndexes i1 i2 = Inverted (substractParts (indexParts i1) (indexParts i2))++ insertOccurrences c w o i = mergeIndexes (singleton c w o) i+ deleteOccurrences c w o i = substractIndexes i (singleton c w o)++ splitByContexts (Inverted ps) = splitInternal (map (uncurry annotate) . M.toList $ ps)+ where+ annotate c p = let+ i = Inverted (M.singleton c p)+ in+ (sizeWords i, i)++ splitByDocuments i = splitInternal ( map convert $+ toListDocIdMap $+ unionsWithDocIdMap unionDocs' docResults+ )+ where+ unionDocs' = M.unionWith (M.unionWith unionPos)+ docResults = map (\c -> resultByDocument c (allWords i c)) (contexts i)+ convert (d, cs) = foldl' makeIndex (0, emptyInverted) (M.toList cs)+ where+ makeIndex r (c, ws) = foldl' makeOcc r (M.toList ws)+ where+ makeOcc (rs, ri) (w, p) = (sizePos p + rs , insertOccurrences c w (singletonDocIdMap d p) ri)++ splitByWords i = splitInternal indexes+ where+ indexes = map convert $+ M.toList $+ M.unionsWith (M.unionWith mergeOccurrences) wordResults+ where+ wordResults = map (\c -> resultByWord c (allWords i c)) (contexts i)+ convert (w, cs) = foldl' makeIndex (0, emptyInverted) (M.toList cs)+ where+ makeIndex (rs, ri) (c, o) = (rs + sizeOccurrences o, insertOccurrences c w o ri)++ updateDocIds f (Inverted parts)+ = Inverted (M.mapWithKey updatePart parts)+ where+ updatePart c p = PT.mapWithKey+ (\w o -> foldWithKeyDocIdMap (updateDocument c w) emptyDocIdMap o) p+ updateDocument c w d p r = insertWithDocIdMap mergePositions (f c w d) p r+ where+ mergePositions p1 p2 = deflatePos $ unionPos (inflatePos p1) (inflatePos p2)++ updateDocIds' f+ = Inverted . M.map updatePart . indexParts+ where+ updatePart = PT.map updateOcc+ updateOcc = foldWithKeyDocIdMap updateId emptyDocIdMap+ updateId = insertDocIdMap . f++ toList i = concat $ map convertPart $ M.toList (indexParts i) + where convertPart (c,p) = map (\(w, o) -> (c, w, inflateOcc o)) $+ PT.toList $+ p++-- ----------------------------------------------------------------------------++instance NFData Inverted where+ rnf = rnf . indexParts++-- ----------------------------------------------------------------------------++instance XmlPickler Inverted where+ xpickle = xpElem "indexes" $+ xpWrap (\p -> Inverted p, \(Inverted p) -> p) xpParts++-- | The XML pickler for the index parts.+xpParts :: PU Parts+xpParts = xpWrap (M.fromList, M.toList) (xpList xpContext)+ where+ xpContext = xpElem "part" (xpPair (xpAttr "id" xpText) xpPart)++-- | The XML pickler for a single part.+xpPart :: PU Part+xpPart = xpElem "index" (xpWrap (PT.fromList, PT.toList) (xpList xpWord))+ where+ xpWord = xpElem "word" $+ xpPair (xpAttr "w" xpText)+ (xpWrap (deflateOcc, inflateOcc) xpOccurrences)++-- ----------------------------------------------------------------------------++instance Binary Inverted where+ put = put . indexParts+ get = get >>= return . Inverted++-- ----------------------------------------------------------------------------++-- | Create an empty index.+emptyInverted :: Inverted+emptyInverted = Inverted M.empty+ +-- | Create an index with just one word in one context.+singleton :: Context -> String -> Occurrences -> Inverted+singleton c w o = Inverted (M.singleton c (PT.singleton w (deflateOcc o)))++-- | Merge two sets of index parts.+mergeParts :: Parts -> Parts -> Parts+mergeParts = M.unionWith mergePart++-- | Merge two index parts.+mergePart :: Part -> Part -> Part+mergePart = PT.unionWith mergeDiffLists+ where+ mergeDiffLists o1 o2 = deflateOcc $+ mergeOccurrences (inflateOcc o1) (inflateOcc o2)++-- | Substract a set of index parts from another.+substractParts :: Parts -> Parts -> Parts+substractParts = M.differenceWith substractPart++-- | Substract one index part from another.+substractPart :: Part -> Part -> Maybe Part+substractPart p1 p2 = if PT.null diffPart then Nothing else Just diffPart+ where+ diffPart = PT.differenceWith substractDiffLists p1 p2+ where+ substractDiffLists o1 o2 = if diffOcc == emptyOccurrences then Nothing else Just (deflateOcc diffOcc)+ where+ diffOcc = substractOccurrences (inflateOcc o1) (inflateOcc o2)++-- | Internal split function used by the split functions from the HolIndex interface (above).+splitInternal :: [(Int, Inverted)] -> Int -> [Inverted]+splitInternal inp n = allocate mergeIndexes stack buckets+ where+ buckets = zipWith const (createBuckets n) stack+ stack = reverse (sortBy (compare `on` fst) inp)++-- | Allocates values from the first list to the buckets in the second list.+allocate :: (a -> a -> a) -> [(Int, a)] -> [(Int, a)] -> [a]+allocate _ _ [] = []+allocate _ [] ys = map snd ys+allocate f (x:xs) (y:ys) = allocate f xs (sortBy (compare `on` fst) ((combine x y):ys))+ where+ combine (s1, v1) (s2, v2) = (s1 + s2, f v1 v2)++-- | Create empty buckets for allocating indexes. +createBuckets :: Int -> [(Int, Inverted)]+createBuckets n = (replicate n (0, emptyInverted))+ +-- | Return a part of the index for a given context.+getPart :: Context -> Inverted -> Part+getPart c i = fromMaybe PT.empty (M.lookup c $ indexParts i)++-- ----------------------------------------------------------------------------
+ src/Holumbus/Query/Fuzzy.hs view
@@ -0,0 +1,218 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Fuzzy+ Copyright : Copyright (C) 2007, 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.2++ The unique Holumbus mechanism for generating fuzzy sets.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Query.Fuzzy + (+ -- * Fuzzy types+ FuzzySet+ , Replacements+ , Replacement+ , FuzzyScore+ , FuzzyConfig (..)+ + -- * Predefined replacements+ , englishReplacements+ , germanReplacements+ + -- * Generation+ , fuzz+ + -- * Conversion+ , toList+ )+where++import Data.Binary+import Data.List+import Data.Function++import Control.Monad++import Data.Map (Map)+import qualified Data.Map as M++-- | A set of string which have been "fuzzed" with an associated score.++type FuzzySet = Map String FuzzyScore++-- | Some replacements which can be applied to a string to generate a 'FuzzySet'. The scores of+-- the replacements will be normalized to a maximum of 1.0.++type Replacements = [ Replacement ]++-- | A single replacements, where the first will be replaced by the second and vice versa in+-- the target string. The score indicates the amount of fuzzines that one single application+-- of this replacement in just one direction will cause on the target string.++type Replacement = ((String, String), FuzzyScore)++-- | The score indicating an amount of fuzziness. ++type FuzzyScore = Float++-- | The configuration of a fuzzy query.++data FuzzyConfig+ = FuzzyConfig + { applyReplacements :: Bool -- ^ Indicates whether the replacements should be applied.+ , applySwappings :: Bool -- ^ Indicates whether the swapping of adjacent characters should be applied.+ , maxFuzziness :: FuzzyScore -- ^ The maximum allowed fuzziness.+ , customReplacements :: Replacements -- ^ The replacements that should be applied.+ }+ deriving (Show)++instance Binary FuzzyConfig where+ put (FuzzyConfig r s m f)+ = put r >> put s >> put m >> put f+ get+ = liftM4 FuzzyConfig get get get get++-- | Some default replacements for the english language.+englishReplacements :: Replacements+englishReplacements =+ [ (("l", "ll"), 0.2)+ , (("t", "tt"), 0.2)+ , (("r", "rr"), 0.2)+ , (("e", "ee"), 0.2)+ , (("o", "oo"), 0.2)+ , (("s", "ss"), 0.2)+ + , (("g", "ck"), 0.4)+ , (("k", "ck"), 0.4)+ , (("ea", "ee"), 0.4)+ , (("ou", "oo"), 0.4)+ , (("ou", "au"), 0.4)+ , (("ou", "ow"), 0.4)++ , (("s", "c"), 0.6)+ , (("uy", "ye"), 0.6)+ , (("y", "ey"), 0.6)+ , (("kn", "n"), 0.6)+ ]++-- | Some default replacements for the german language.++germanReplacements :: Replacements+germanReplacements = + [ (("l", "ll"), 0.2)+ , (("t", "tt"), 0.2)+ , (("n", "nn"), 0.2)+ , (("r", "rr"), 0.2)+ , (("i", "ie"), 0.2)+ , (("ei", "ie"), 0.2)+ , (("k", "ck"), 0.2)++ , (("d", "t"), 0.4)+ , (("b", "p"), 0.4)+ , (("g", "k"), 0.4)+ , (("g", "ch"), 0.4)+ , (("c", "k"), 0.4)+ , (("s", "z"), 0.4)+ , (("u", "ou"), 0.4)++ , (("ü", "ue"), 0.1)+ , (("ä", "ae"), 0.1)+ , (("ö", "oe"), 0.1)+ , (("ß", "ss"), 0.1)+ ]++-- | Continue fuzzing a string with the an explicitly specified list of replacements until +-- a given score threshold is reached.++fuzz :: FuzzyConfig -> String -> FuzzySet+fuzz cfg s = M.delete s (fuzz' (fuzzLimit cfg 0.0 s))+ where+ fuzz' :: FuzzySet -> FuzzySet+ fuzz' fs = if M.null more then fs else M.unionWith min fs (fuzz' more)+ where+ -- The current score is doubled on every recursive call, because fuzziness increases exponentially.+ more = M.foldrWithKey (\sm sc res -> M.unionWith min res (fuzzLimit cfg (sc + sc) sm)) M.empty fs++-- | Fuzz a string and limit the allowed score to a given threshold.++fuzzLimit :: FuzzyConfig -> FuzzyScore -> String -> FuzzySet+fuzzLimit cfg sc s = if sc <= th then M.filter (\ns -> ns <= th) (fuzzInternal cfg sc s) else M.empty+ where+ th = maxFuzziness cfg++-- | Fuzz a string with an list of explicitly specified replacements and combine the scores+-- with an initial score.++fuzzInternal :: FuzzyConfig -> FuzzyScore -> String -> FuzzySet+fuzzInternal cfg sc s = M.unionWith min replaced swapped+ where+ replaced = let rs = customReplacements cfg in if (applyReplacements cfg) + then foldr (\r res -> M.unionWith min res (applyFuzz (replace rs r) sc s)) M.empty rs+ else M.empty+ swapped = if (applySwappings cfg) + then applyFuzz swap sc s+ else M.empty++-- | Applies a fuzzy function to a string. An initial score is combined with the new score +-- for the replacement.++applyFuzz :: (String -> String -> [(String, FuzzyScore)]) -> FuzzyScore -> String -> FuzzySet+applyFuzz f sc s = apply (init $ inits s) (init $ tails s)+ where+ apply :: [String] -> [String] -> FuzzySet+ apply [] _ = M.empty+ apply _ [] = M.empty+ apply (pr:prs) (su:sus) = M.unionsWith min $ (apply prs sus):(map create $ (f pr su))+ where+ create (fuzzed, score) = M.singleton fuzzed (sc + score * (calcWeight (length pr) (length s)))+ +-- | Apply a replacement in both directions to the suffix of a string and return the complete+-- string with a score, calculated from the replacement itself and the list of replacements.++replace :: Replacements -> Replacement -> String -> String -> [(String, FuzzyScore)]+replace rs ((r1, r2), s) prefix suffix = (replace' r1 r2) ++ (replace' r2 r1)+ where+ replace' tok sub = if replaced == suffix then [] else [(prefix ++ replaced, score)]+ where+ replaced = replaceFirst tok sub suffix+ score = s / (snd $ maximumBy (compare `on` snd) rs)+ +-- | Swap the first two characters of the suffix and return the complete string with a score or+-- Nothing if there are not enough characters to swap.++swap :: String -> String -> [(String, FuzzyScore)]+swap prefix (s1:s2:suffix) = [(prefix ++ (s2:s1:suffix), 1.0)]+swap _ _ = []++-- | Calculate the weighting factor depending on the position in the string and it's total length.++calcWeight :: Int -> Int -> FuzzyScore+calcWeight pos len = (l - p) / l+ where+ p = fromIntegral pos+ l = fromIntegral len++-- | Searches a prefix and replaces it with a substitute in a list.++replaceFirst :: Eq a => [a] -> [a] -> [a] -> [a]+replaceFirst [] ys zs = ys ++ zs+replaceFirst _ _ [] = []+replaceFirst t@(x:xs) ys s@(z:zs) = if x == z && t `isPrefixOf` s then + if null ys then replaceFirst xs [] zs + else (head ys) : replaceFirst xs (tail ys) zs+ else s++-- | Transform a fuzzy set into a list (ordered by score).++toList :: FuzzySet -> [ (String, FuzzyScore) ]+toList = sortBy (compare `on` snd) . M.toList
+ src/Holumbus/Query/Intermediate.hs view
@@ -0,0 +1,175 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Intermediate+ Copyright : Copyright (C) 2007, 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.3++ The data type for intermediate results occuring during query processing.++-}++-- ----------------------------------------------------------------------------++{-# OPTIONS #-}++module Holumbus.Query.Intermediate +(+ -- * The intermediate result type.+ Intermediate ++ -- * Construction+ , emptyIntermediate++ -- * Query+ , null+ , sizeIntermediate++ -- * Combine+ , union+ , difference+ , intersection + , unions+ + -- * Conversion+ , fromList+ , toResult+)+where++import Prelude hiding (null)++import Data.Maybe++import qualified Data.List as L++import Data.Map (Map)+import qualified Data.Map as M++import Holumbus.Query.Result hiding (null)++import Holumbus.Index.Common hiding (toList, fromList)++-- ----------------------------------------------------------------------------++-- | The intermediate result used during query processing.++type Intermediate = DocIdMap IntermediateContexts+type IntermediateContexts = Map Context IntermediateWords+type IntermediateWords = Map Word (WordInfo, Positions)++-- ----------------------------------------------------------------------------++-- | Create an empty intermediate result.++emptyIntermediate :: Intermediate+emptyIntermediate = emptyDocIdMap++-- | Check if the intermediate result is empty.++null :: Intermediate -> Bool+null = nullDocIdMap++-- | Returns the number of documents in the intermediate result.++sizeIntermediate :: Intermediate -> Int+sizeIntermediate = sizeDocIdMap++-- | Merges a bunch of intermediate results into one intermediate result by unioning them.++unions :: [Intermediate] -> Intermediate+unions = L.foldl' union emptyIntermediate++-- | Intersect two sets of intermediate results.++intersection :: Intermediate -> Intermediate -> Intermediate+intersection = intersectionWithDocIdMap combineContexts++-- | Union two sets of intermediate results.++union :: Intermediate -> Intermediate -> Intermediate+union = unionWithDocIdMap combineContexts++-- | Substract two sets of intermediate results.++difference :: Intermediate -> Intermediate -> Intermediate+difference = differenceDocIdMap++-- | Create an intermediate result from a list of words and their occurrences.++fromList :: Word -> Context -> RawResult -> Intermediate+-- Beware! This is extremly optimized and will not work for merging arbitrary intermediate results!+-- Based on resultByDocument from Holumbus.Index.Common++fromList t c os = mapDocIdMap transform $+ unionsWithDocIdMap (flip $ (:) . head)+ (map insertWords os)+ where+ insertWords (w, o) = mapDocIdMap (\p -> [(w, (WordInfo [t] 0.0 , p))]) o + transform w = M.singleton c (M.fromList w)++-- | Convert to a @Result@ by generating the 'WordHits' structure.++toResult :: HolDocuments d c => d c -> Intermediate -> Result c+toResult d im = Result (createDocHits d im) (createWordHits im)++-- | Create the doc hits structure from an intermediate result.++createDocHits :: HolDocuments d c => d c -> Intermediate -> DocHits c+createDocHits d im = mapWithKeyDocIdMap transformDocs im+ where+ transformDocs did ic = let doc = fromMaybe (Document "" "" Nothing) (lookupById d did) in+ (DocInfo doc 0.0, M.map (M.map (\(_, p) -> p)) ic)++-- | Create the word hits structure from an intermediate result.++createWordHits :: Intermediate -> WordHits+createWordHits im = foldWithKeyDocIdMap transformDoc M.empty im+ where+ transformDoc d ic wh = M.foldrWithKey transformContext wh ic+ where+ transformContext c iw wh' = M.foldrWithKey insertWord wh' iw+ where+ insertWord w (wi, pos) wh''+ = if terms wi == [""]+ then wh'' + else M.insertWith combineWordHits+ w+ (wi, M.singleton c (singletonDocIdMap d pos))+ wh''++-- | Combine two tuples with score and context hits.++combineWordHits :: (WordInfo, WordContextHits) ->+ (WordInfo, WordContextHits) -> (WordInfo, WordContextHits)+combineWordHits (i1, c1) (i2, c2)+ = ( combineWordInfo i1 i2+ , M.unionWith (unionWithDocIdMap unionPos) c1 c2+ )++-- | Combine two tuples with score and context hits.++combineContexts :: IntermediateContexts -> IntermediateContexts -> IntermediateContexts+combineContexts = M.unionWith (M.unionWith merge)+ where+ merge (i1, p1) (i2, p2) = ( combineWordInfo i1 i2+ , unionPos p1 p2+ )++-- | Combine two word informations.++combineWordInfo :: WordInfo -> WordInfo -> WordInfo+combineWordInfo (WordInfo t1 s1) (WordInfo t2 s2)+ = WordInfo (t1 ++ t2) (combineScore s1 s2)++-- | Combine two scores (just average between them).++combineScore :: Score -> Score -> Score+combineScore s1 s2 = (s1 + s2) / 2.0++-- ----------------------------------------------------------------------------
+ src/Holumbus/Query/Language/Grammar.hs view
@@ -0,0 +1,144 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Language.Grammar+ Copyright : Copyright (C) 2007, 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.2++ The Holumbus query language definition. + + The specific syntax of any query language can be designed independently + by creating appropriate parsers. Also see "Holumbus.Query.Language.Parser".++-}++-- ----------------------------------------------------------------------------++module Holumbus.Query.Language.Grammar+ (+ -- * Query data types+ Query (Word, Phrase, CaseWord, CasePhrase, FuzzyWord, Specifier, Negation, BinQuery)+ , BinOp (And, Or, But)++ -- * Optimizing+ , optimize+ , checkWith+ , extractTerms+ )+where++import Data.Char+import Data.List+import Data.Binary+import Control.Monad++import Holumbus.Index.Common (Context)++-- | The query language.+data Query = Word String -- ^ Single case-insensitive word.+ | Phrase String -- ^ Single case-insensitive phrase.+ | CaseWord String -- ^ Single case-sensitive word.+ | CasePhrase String -- ^ Single case-sensitive phrase.+ | FuzzyWord String -- ^ Single fuzzy word.+ | Specifier [Context] Query -- ^ Restrict query to a list of contexts.+ | Negation Query -- ^ Negate the query.+ | BinQuery BinOp Query Query -- ^ Combine two queries through a binary operation.+ deriving (Eq, Show)++-- | A binary operation.+data BinOp = And -- ^ Intersect two queries.+ | Or -- ^ Union two queries.+ | But -- ^ Filter a query by another, @q1 BUT q2@ is equivalent to @q1 AND NOT q2@.+ deriving (Eq, Show)++instance Binary Query where+ put (Word s) = put (0 :: Word8) >> put s+ put (Phrase s) = put (1 :: Word8) >> put s+ put (CaseWord s) = put (2 :: Word8) >> put s+ put (CasePhrase s) = put (3 :: Word8) >> put s+ put (FuzzyWord s) = put (4 :: Word8) >> put s+ put (Specifier c q) = put (5 :: Word8) >> put c >> put q+ put (Negation q) = put (6 :: Word8) >> put q+ put (BinQuery o q1 q2) = put (7 :: Word8) >> put o >> put q1 >> put q2++ get = do tag <- getWord8+ case tag of+ 0 -> liftM Word get+ 1 -> liftM Phrase get+ 2 -> liftM CaseWord get+ 3 -> liftM CasePhrase get+ 4 -> liftM FuzzyWord get+ 5 -> liftM2 Specifier get get+ 6 -> liftM Negation get+ 7 -> liftM3 BinQuery get get get+ _ -> fail "Error while decoding Query" ++instance Binary BinOp where+ put And = put (0 :: Word8)+ put Or = put (1 :: Word8)+ put But = put (2 :: Word8)++ get = do tag <- getWord8+ case tag of+ 0 -> return And+ 1 -> return Or+ 2 -> return But+ _ -> fail "Error while decoding BinOp"++-- | Transforms all @(BinQuery And q1 q2)@ where one of @q1@ or @q2@ is a @Negation@ into+-- @BinQuery Filter q1 q2@ or @BinQuery Filter q2 q1@ respectively.+optimize :: Query -> Query++optimize q@(BinQuery And (Word q1) (Word q2)) = + if (map toLower q1) `isPrefixOf` (map toLower q2) then Word q2 else+ if (map toLower q2) `isPrefixOf` (map toLower q1) then Word q1 else q++optimize q@(BinQuery And (CaseWord q1) (CaseWord q2)) = + if q1 `isPrefixOf` q2 then CaseWord q2 else+ if q2 `isPrefixOf` q1 then CaseWord q1 else q++optimize q@(BinQuery Or (Word q1) (Word q2)) =+ if (map toLower q1) `isPrefixOf` (map toLower q2) then Word q1 else+ if (map toLower q2) `isPrefixOf` (map toLower q1) then Word q2 else q++optimize q@(BinQuery Or (CaseWord q1) (CaseWord q2)) =+ if q1 `isPrefixOf` q2 then CaseWord q1 else+ if q2 `isPrefixOf` q1 then CaseWord q2 else q++optimize (BinQuery And q1 (Negation q2)) = BinQuery But (optimize q1) (optimize q2)+optimize (BinQuery And (Negation q1) q2) = BinQuery But (optimize q2) (optimize q1)++optimize (BinQuery And q1 q2) = BinQuery And (optimize q1) (optimize q2)+optimize (BinQuery Or q1 q2) = BinQuery Or (optimize q1) (optimize q2)+optimize (BinQuery But q1 q2) = BinQuery But (optimize q1) (optimize q2)+optimize (Negation q) = Negation (optimize q)+optimize (Specifier cs q) = Specifier cs (optimize q)++optimize q = q++-- | Check if the query arguments comply with some custom predicate.+checkWith :: (String -> Bool) -> Query -> Bool+checkWith f (Word s) = f s+checkWith f (Phrase s) = f s+checkWith f (CaseWord s) = f s+checkWith f (CasePhrase s) = f s+checkWith f (FuzzyWord s) = f s+checkWith f (Negation q) = checkWith f q+checkWith f (BinQuery _ q1 q2) = (checkWith f q1) && (checkWith f q2)+checkWith f (Specifier _ q) = checkWith f q++-- | Returns a list of all terms in the query.+extractTerms :: Query -> [String]+extractTerms (Word s) = [s]+extractTerms (CaseWord s) = [s]+extractTerms (FuzzyWord s) = [s]+extractTerms (Specifier _ q) = extractTerms q+extractTerms (Negation q) = extractTerms q+extractTerms (BinQuery _ q1 q2) = (extractTerms q1) ++ (extractTerms q2)+extractTerms _ = []+
+ src/Holumbus/Query/Language/Parser.hs view
@@ -0,0 +1,181 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Language.Parser+ Copyright : Copyright (C) 2007, 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.2++ The Holumbus query parser, based on the famous Parsec library.++ The parser implements a default syntax for the query grammar which exposes+ all possible query types and operators to the user.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Query.Language.Parser+ (+ -- * Parsing+ parseQuery+ )+where++import Holumbus.Query.Language.Grammar+import Text.ParserCombinators.Parsec++-- ----------------------------------------------------------------------------++-- | Parse a query using the default syntax provided by the Holumbus framework.+parseQuery :: String -> Either String Query+parseQuery = result . (parse query "")+ where+ result (Left err) = Left (show err)+ result (Right q) = Right q++-- | A query may always be surrounded by whitespace+query :: Parser Query+query = spaces >> andQuery++-- | Parse an and query.+andQuery :: Parser Query+andQuery = do t <- orQuery+ try (andOp' t) <|> return t+ where+ andOp' r = do andOp+ q <- andQuery+ return (BinQuery And r q)++-- | Parse an or query.+orQuery :: Parser Query+orQuery = do t <- notQuery+ do orOp+ q <- orQuery+ return (BinQuery Or t q)+ <|> return t++-- | Parse a negation.+notQuery :: Parser Query+notQuery = do notQuery' <|> contextQuery+ where+ notQuery' = do notOp+ q <- contextQuery+ return (Negation q)++-- | Parse a context query.+contextQuery :: Parser Query+contextQuery = try contextQuery' <|> parQuery+ where+ contextQuery' = do c <- contexts+ spaces+ char ':'+ spaces+ t <- parQuery+ return (Specifier c t)++-- | Parse a query surrounded by parentheses.+parQuery :: Parser Query+parQuery = parQuery' <|> caseQuery+ where+ parQuery' = do char '('+ spaces+ q <- andQuery+ spaces+ char ')'+ return q++-- | Parse a case-sensitive query.+caseQuery :: Parser Query+caseQuery = caseQuery' <|> fuzzyQuery+ where+ caseQuery' = do char '!'+ spaces+ (phraseQuery CasePhrase <|> wordQuery CaseWord)++-- | Parse a fuzzy query.+fuzzyQuery :: Parser Query+fuzzyQuery = fuzzyQuery' <|> phraseQuery Phrase <|> wordQuery Word+ where+ fuzzyQuery' = do char '~'+ spaces+ wordQuery FuzzyWord++-- | Parse a word query.+wordQuery :: (String -> Query) -> Parser Query+wordQuery c = do w <- word+ return (c w)++-- | Parse a phrase query.+phraseQuery :: (String -> Query) -> Parser Query+phraseQuery c = do p <- phrase+ return (c p)++-- | Parse an and operator.+andOp :: Parser ()+andOp = (try andOp') <|> spaces1+ where+ andOp' = do spaces+ string "AND"+ spaces1+ return ()++-- | Parse an or operator.+orOp :: Parser ()+orOp = try orOp'+ where+ orOp' = do spaces+ string "OR"+ spaces1+ return ()++-- | Parse a not operator.+notOp :: Parser ()+notOp = try notOp'+ where+ notOp' = do spaces+ string "NOT"+ spaces1+ return ()++-- | Parse a word.+word :: Parser String+word = many1 wordChar++-- | Parse a phrase.+phrase :: Parser String+phrase = do char '"'+ p <- many1 phraseChar+ char '"'+ return p++-- | Parse a character of a word.+wordChar :: Parser Char+wordChar = noneOf "\")( "++-- | Parse a character of a phrases.+phraseChar :: Parser Char+phraseChar = noneOf "\""++-- | Parse a list of contexts.+contexts :: Parser [String]+contexts = context `sepBy1` (char ',')++-- | Parse a context.+context :: Parser String+context = do spaces+ c <- (many1 alphaNum)+ spaces+ return c++-- | Parse at least on white space character.+spaces1 :: Parser ()+spaces1 = skipMany1 space++-- ------------------------------------------------------------
+ src/Holumbus/Query/Processor.hs view
@@ -0,0 +1,352 @@+{-# OPTIONS #-}++-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Processor+ Copyright : Copyright (C) 2007, 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable++ The Holumbus query processor. Supports exact word or phrase queries as well+ as fuzzy word and case-insensitive word and phrase queries. Boolean+ operators like AND, OR and NOT are supported. Context specifiers and+ priorities are supported, too.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Query.Processor + (+ -- * Processor types+ ProcessConfig (..)+ + -- * Processing+ , processQuery+ , processPartial+ , processQueryM+ , processPartialM+ )+where++-- import Data.Maybe++import Control.Monad+import Control.Parallel.Strategies++import Data.Binary ( Binary (..) )+import Data.Function+import qualified Data.List as L++import Holumbus.Index.Common hiding (contexts)+import qualified Holumbus.Index.Common as IDX++import Holumbus.Query.Language.Grammar++import Holumbus.Query.Fuzzy ( FuzzyScore+ , FuzzyConfig+ )+import qualified Holumbus.Query.Fuzzy as F++import Holumbus.Query.Result ( Result )++import Holumbus.Query.Intermediate ( Intermediate )+import qualified Holumbus.Query.Intermediate as I++-- ----------------------------------------------------------------------------++-- | The configuration for the query processor.++data ProcessConfig+ = ProcessConfig + { fuzzyConfig :: ! FuzzyConfig -- ^ The configuration for fuzzy queries.+ , optimizeQuery :: ! Bool -- ^ Optimize the query before processing.+ , wordLimit :: ! Int -- ^ The maximum number of words used from a prefix. Zero switches off limiting.+ , docLimit :: ! Int -- ^ The maximum number of documents taken into account. Zero switches off limiting.+ }++instance Binary ProcessConfig where+ put (ProcessConfig fc o l d)+ = put fc >> put o >> put l >> put d+ get+ = liftM4 ProcessConfig get get get get++-- | The internal state of the query processor.+data ProcessState i+ = ProcessState + { config :: ! ProcessConfig -- ^ The configuration for the query processor.+ , contexts :: ! [Context] -- ^ The current list of contexts.+ , index :: ! i -- ^ The index to search.+ , total :: ! Int -- ^ The number of documents in the index.+ }++-- ----------------------------------------------------------------------------++-- | Get the fuzzy config out of the process state.++getFuzzyConfig :: HolIndex i => ProcessState i -> FuzzyConfig+getFuzzyConfig = fuzzyConfig . config++-- | Monadic version of 'getFuzzyConfig'.++getFuzzyConfigM :: HolIndexM m i => ProcessState i -> m FuzzyConfig+getFuzzyConfigM s = return $ fuzzyConfig $ config s++-- | Set the current context in the state.++setContexts :: HolIndex i => [Context] -> ProcessState i -> ProcessState i+setContexts cs (ProcessState cfg _ i t) = ProcessState cfg cs i t++-- | Monadic version of 'setContexts'.++setContextsM :: HolIndexM m i => [Context] -> ProcessState i -> m (ProcessState i)+setContextsM cs (ProcessState cfg _ i t) = return $ ProcessState cfg cs i t++-- | Initialize the state of the processor.++initState :: HolIndex i => ProcessConfig -> i -> Int -> ProcessState i+initState cfg i t = ProcessState cfg (IDX.contexts i) i t++-- | Monadic version of 'initState'.++initStateM :: HolIndexM m i => ProcessConfig -> i -> Int -> m (ProcessState i)+initStateM cfg i t = IDX.contextsM i >>= \cs -> return $ ProcessState cfg cs i t++-- | Try to evaluate the query for all contexts in parallel.++forAllContexts :: (Context -> Intermediate) -> [Context] -> Intermediate+forAllContexts f cs = L.foldl' I.union I.emptyIntermediate $ parMap rdeepseq f cs++-- | Monadic version of 'forAllContexts'.++forAllContextsM :: Monad m => (Context -> m Intermediate) -> [Context] -> m Intermediate+forAllContextsM f cs = mapM f cs >>= \is -> return $ L.foldl' I.union I.emptyIntermediate is++-- | Just everything.++allDocuments :: HolIndex i => ProcessState i -> Intermediate+allDocuments s = forAllContexts (\c -> I.fromList "" c $ IDX.allWords (index s) c) (contexts s)++allDocumentsM :: HolIndexM m i => ProcessState i -> m Intermediate+allDocumentsM s = forAllContextsM (\c -> IDX.allWordsM (index s) c >>= \r -> return $ I.fromList "" c r) (contexts s)++-- | Process a query only partially in terms of a distributed index. Only the intermediate +-- result will be returned.++processPartial :: (HolIndex i) => ProcessConfig -> i -> Int -> Query -> Intermediate+processPartial cfg i t q = process (initState cfg i t) oq+ where+ oq = if optimizeQuery cfg then optimize q else q++-- | Monadic version of 'processPartial'.++processPartialM :: (HolIndexM m i) => ProcessConfig -> i -> Int -> Query -> m Intermediate+processPartialM cfg i t q = initStateM cfg i t >>= (flip processM) oq+ where+ oq = if optimizeQuery cfg then optimize q else q++-- | Process a query on a specific index with regard to the configuration.++processQuery :: (HolIndex i, HolDocuments d c) => ProcessConfig -> i -> d c -> Query -> Result c+processQuery cfg i d q = I.toResult d (processPartial cfg i (sizeDocs d) q)++-- | Monadic version of 'processQuery'.++processQueryM :: (HolIndexM m i, HolDocuments d c) => ProcessConfig -> i -> d c -> Query -> m (Result c)+processQueryM cfg i d q = processPartialM cfg i (sizeDocs d) q >>= \ir -> return $ I.toResult d ir++-- | Continue processing a query by deciding what to do depending on the current query element.++process :: HolIndex i => ProcessState i -> Query -> Intermediate+process s (Word w) = processWord s w+process s (Phrase w) = processPhrase s w+process s (CaseWord w) = processCaseWord s w+process s (CasePhrase w) = processCasePhrase s w+process s (FuzzyWord w) = processFuzzyWord s w+process s (Negation q) = processNegation s (process s q)+process s (Specifier c q) = process (setContexts c s) q+process s (BinQuery o q1 q2) = processBin o (process s q1) (process s q2)++-- | Monadic version of 'process'.++processM :: HolIndexM m i => ProcessState i -> Query -> m Intermediate+processM s (Word w) = processWordM s w+processM _ (Phrase _) = return I.emptyIntermediate -- processPhraseM s w+processM s (CaseWord w) = processCaseWordM s w+processM _ (CasePhrase _) = return I.emptyIntermediate -- processCasePhraseM s w+processM s (FuzzyWord w) = processFuzzyWordM s w+processM s (Negation q) = processM s q >>= processNegationM s+processM s (Specifier c q) = setContextsM c s >>= \ns -> processM ns q+processM s (BinQuery o q1 q2) = do+ ir1 <- processM s q1+ ir2 <- processM s q2+ return $ processBin o ir1 ir2++-- | Process a single, case-insensitive word by finding all documents whreturn I.emptyIntermediate -- ich contain the word as prefix.++processWord :: HolIndex i => ProcessState i -> String -> Intermediate+processWord s q = forAllContexts wordNoCase (contexts s)+ where+ wordNoCase c = I.fromList q c $ limitWords s $ IDX.prefixNoCase (index s) c q++-- | Monadic version of 'processWord'.++processWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate+processWordM s q = forAllContextsM wordNoCase (contexts s)+ where+ wordNoCase c = IDX.prefixNoCaseM (index s) c q >>= limitWordsM s >>= \r -> return $ I.fromList q c r++-- | Process a single, case-sensitive word by finding all documents which contain the word as prefix.++processCaseWord :: HolIndex i => ProcessState i -> String -> Intermediate+processCaseWord s q = forAllContexts wordCase (contexts s)+ where+ wordCase c = I.fromList q c $ limitWords s $ IDX.prefixCase (index s) c q++-- | Monadic version of 'processCaseWord'.++processCaseWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate+processCaseWordM s q = forAllContextsM wordCase (contexts s)+ where+ wordCase c = IDX.prefixCaseM (index s) c q >>= limitWordsM s >>= \r -> return $ I.fromList q c r++-- | Process a phrase case-insensitive.++processPhrase :: HolIndex i => ProcessState i -> String -> Intermediate+processPhrase s q = forAllContexts phraseNoCase (contexts s)+ where+ phraseNoCase c = processPhraseInternal (IDX.lookupNoCase (index s) c) c q++-- processPhraseM :: HolIndexM m i => ProcessState i -> String -> m Intermediate+-- processPhraseM s q = forAllContextsM phraseNoCase (contexts s)+-- where+-- phraseNoCase c = ++-- | Process a phrase case-sensitive.++processCasePhrase :: HolIndex i => ProcessState i -> String -> Intermediate+processCasePhrase s q = forAllContexts phraseCase (contexts s)+ where+ phraseCase c = processPhraseInternal (IDX.lookupCase (index s) c) c q++-- | Process a phrase query by searching for every word of the phrase and comparing their positions.++processPhraseInternal :: (String -> RawResult) -> Context -> String -> Intermediate+processPhraseInternal f c q = let+ w = words q + m = mergeOccurrencesList $ map snd $ f (head w) in+ if nullDocIdMap m+ then I.emptyIntermediate+ else I.fromList q c [(q, processPhrase' (tail w) 1 m)]+ where+ processPhrase' :: [String] -> Position -> Occurrences -> Occurrences+ processPhrase' [] _ o = o+ processPhrase' (x:xs) p o = processPhrase' xs (p+1) (filterWithKeyDocIdMap (nextWord $ map snd $ f x) o)+ where+ nextWord :: [Occurrences] -> DocId -> Positions -> Bool+ nextWord [] _ _ = False+ nextWord no d np = maybe False hasSuccessor (lookupDocIdMap d (mergeOccurrencesList no))+ where+ hasSuccessor :: Positions -> Bool+ hasSuccessor w = foldPos (\cp r -> r || (memberPos (cp + p) w)) False np++-- | Process a single word and try some fuzzy alternatives if nothing was found.++processFuzzyWord :: HolIndex i => ProcessState i -> String -> Intermediate+processFuzzyWord s oq = processFuzzyWord' (F.toList $ F.fuzz (getFuzzyConfig s) oq) (processWord s oq)+ where+ processFuzzyWord' :: [(String, FuzzyScore)] -> Intermediate -> Intermediate+ processFuzzyWord' [] r = r+ processFuzzyWord' (q:qs) r = if I.null r then processFuzzyWord' qs (processWord s (fst q)) else r++-- | Monadic version of 'processFuzzyWord'.++processFuzzyWordM :: HolIndexM m i => ProcessState i -> String -> m Intermediate+processFuzzyWordM s oq = do+ sr <- processWordM s oq + cfg <- getFuzzyConfigM s+ processFuzzyWordM' (F.toList $ F.fuzz cfg oq) sr+ where+ processFuzzyWordM' [] r = return r+ processFuzzyWordM' (q:qs) r = if I.null r+ then processWordM s (fst q) >>= processFuzzyWordM' qs+ else return r++-- | Process a negation by getting all documents and substracting the result of the negated query.++processNegation :: HolIndex i => ProcessState i -> Intermediate -> Intermediate+processNegation s r = I.difference (allDocuments s) r++-- | Monadic version of 'processNegation'.++processNegationM :: HolIndexM m i => ProcessState i -> Intermediate -> m Intermediate+processNegationM s r1 = allDocumentsM s >>= \r2 -> return $ I.difference r2 r1++-- | Process a binary operator by caculating the union or the intersection of the two subqueries.++processBin :: BinOp -> Intermediate -> Intermediate -> Intermediate+processBin And r1 r2 = I.intersection r1 r2+processBin Or r1 r2 = I.union r1 r2+processBin But r1 r2 = I.difference r1 r2+++-- | Limit a 'RawResult' to a fixed amount of the best words.+--+-- First heuristic applied is limiting the number of documents in the result,+-- assuming the short words come first in the result list+-- So the length of the result list depends on the number of documents found.+--+-- TODO: This is fixed to 2000, should be part of the config part of the state+--+-- A 2. simple heuristic is used to +-- determine the quality of a word: The total number of occurrences divided by the number of +-- documents in which the word appears.+--+-- The second heuristic isn't that expensive any more when the resul list is cut of by the heuristic+--+-- The limit 500 should be part of a configuration++limitWords :: ProcessState i -> RawResult -> RawResult+limitWords s r = cutW . cutD $ r+ where+ limitD = docLimit $ config s+ cutD+ | limitD > 0 = limitDocs limitD+ | otherwise = id++ limitW = wordLimit $ config s+ cutW+ | limitW > 0+ &&+ length r > limitW+ = map snd . take limitW . L.sortBy (compare `on` fst) . map calcScore+ | otherwise = id++ calcScore :: (Word, Occurrences) -> (Double, (Word, Occurrences))+ calcScore w@(_, o) = (log (fromIntegral (total s) / fromIntegral (sizeDocIdMap o)), w)++-- ----------------------------------------------------------------------------++-- | Limit the number of docs in a raw result++limitDocs :: Int -> RawResult -> RawResult+limitDocs _ [] = []+limitDocs limit _+ | limit <= 0 = []+limitDocs limit (x:xs) = x : limitDocs (limit - sizeDocIdMap (snd x)) xs++-- ----------------------------------------------------------------------------++-- | Monadic version of 'limitWords'.+limitWordsM :: (Monad m) => ProcessState i -> RawResult -> m RawResult+limitWordsM s r = return $ limitWords s r++-- | Merge occurrences+mergeOccurrencesList :: [Occurrences] -> Occurrences+mergeOccurrencesList = unionsWithDocIdMap unionPos++-- ----------------------------------------------------------------------------
+ src/Holumbus/Query/Ranking.hs view
@@ -0,0 +1,129 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Ranking+ Copyright : Copyright (C) 2007, 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.3++ The ranking mechanism for Holumbus. + + Customized ranking functions for both documents and suggested words can be + provided by the user. Some predefined ranking functions are avaliable, too.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Query.Ranking + (+ -- * Ranking types+ RankConfig (..)+ , DocRanking+ , WordRanking+ + -- * Ranking+ , rank+ + -- * Predefined document rankings+ , docRankByCount+ , docRankWeightedByCount+ + -- * Predefined word rankings+ , wordRankByCount+ , wordRankWeightedByCount+ )+where++import Prelude hiding (foldr)++import Data.Function+import Data.Foldable++import qualified Data.List as L+import qualified Data.Map as M++import Holumbus.Query.Result+import Holumbus.Index.Common++-- ----------------------------------------------------------------------------++-- | The configuration of the ranking mechanism.+data RankConfig a = RankConfig + { docRanking :: DocRanking a -- ^ A function to determine the score of a document.+ , wordRanking :: WordRanking -- ^ A funciton to determine the score of a word.+ }++-- | The signature of a function to determine the score of a document.+type DocRanking a = DocId -> DocInfo a -> DocContextHits -> Score++-- | The signature of a function to determine the score of a word.+type WordRanking = Word -> WordInfo -> WordContextHits -> Score++-- ----------------------------------------------------------------------------++-- | Rank the result with custom ranking functions.++rank :: RankConfig a -> Result a -> Result a+rank (RankConfig fd fw {-ld lw-}) r+ = Result scoredDocHits scoredWordHits+ where+ scoredDocHits = mapWithKeyDocIdMap (\k (di, dch) -> (setDocScore (fd k di dch) di, dch)) $+ docHits r+ scoredWordHits = M.mapWithKey (\k (wi, wch) -> (setWordScore (fw k wi wch) wi, wch)) $+ wordHits r++-- | Rank documents by count.++docRankByCount :: DocId -> DocInfo a -> DocContextHits -> Score+docRankByCount _ _ h = fromIntegral $+ M.fold (\h1 r1 -> M.fold (\h2 r2 -> sizePos h2 + r2) r1 h1) 0 h++-- | Rank words by count.++wordRankByCount :: Word -> WordInfo -> WordContextHits -> Score+wordRankByCount _ _ h = fromIntegral $ M.fold (\h1 r1 -> foldDocIdMap ((+) . sizePos) r1 h1) 0 h++-- | Rank documents by context-weighted count. The weights will be normalized to a maximum of 1.0.+-- Contexts with no weight (or a weight of zero) will be ignored.++docRankWeightedByCount :: [(Context, Score)] -> DocId -> DocInfo a -> DocContextHits -> Score+docRankWeightedByCount ws _ _ h+ = M.foldrWithKey (calcWeightedScore ws) 0.0 h++-- | Rank words by context-weighted count. The weights will be normalized to a maximum of 1.0.+-- Contexts with no weight (or a weight of zero) will be ignored.++wordRankWeightedByCount :: [(Context, Score)] -> Word -> WordInfo -> WordContextHits -> Score+wordRankWeightedByCount ws _ _ h+ = M.foldrWithKey (calcWeightedScore ws) 0.0 h++-- | Calculate the weighted score of occurrences of a word.++calcWeightedScore :: (Foldable f) =>+ [(Context, Score)] -> Context -> (f Positions) -> Score -> Score+calcWeightedScore ws c h r+ = maybe r (\w -> r + ((w / mw) * count)) $+ lookupWeight c ws+ where+ count = fromIntegral $+ foldl' (flip $ (+) . sizePos) 0 h+ mw = snd $+ L.maximumBy (compare `on` snd) ws++-- | Find the weight of a context in a list of weights. If the context was not found or it's+-- weight is equal to zero, 'Nothing' will be returned.++lookupWeight :: Context -> [(Context, Score)] -> Maybe Score+lookupWeight _ [] = Nothing+lookupWeight c (x:xs) = if fst x == c+ then if snd x /= 0.0+ then Just (snd x)+ else Nothing+ else lookupWeight c xs++-- ----------------------------------------------------------------------------
+ src/Holumbus/Query/Result.hs view
@@ -0,0 +1,260 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Query.Result+ Copyright : Copyright (C) 2007 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable++ The data type for results of Holumbus queries.++ The result of a query is defined in terms of two partial results, + the documents containing the search terms and the words which + are possible completions of the serach terms.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Query.Result + (+ -- * Result data types+ Result (..)+ , DocHits+ , DocContextHits+ , DocWordHits+ , WordHits+ , WordContextHits+ , WordDocHits+ , DocInfo (..)+ , WordInfo (..)+ , Score+ + -- * Construction+ , emptyResult++ -- * Query+ , null+ , sizeDocHits+ , sizeWordHits+ , maxScoreDocHits+ , maxScoreWordHits+ , getDocuments++ -- * Transform+ , setDocScore+ , setWordScore+ + -- * Picklers+ , xpDocHits+ , xpWordHits+ )+where++import Prelude hiding (null)++import Control.DeepSeq+import Control.Monad ( liftM2 )++import Data.Binary ( Binary (..) )+import Data.Function+import Data.Map (Map)+import qualified+ Data.Map as M+import qualified+ Data.List as L++import Holumbus.Utility+import Holumbus.Index.Common++import Text.XML.HXT.Core++-- ----------------------------------------------------------------------------++-- | The combined result type for Holumbus queries.+data Result a = Result + { docHits :: (DocHits a) -- ^ The documents matching the query.+ , wordHits :: WordHits -- ^ The words which are completions of the query terms.+ }+ deriving (Eq, Show)++-- | Information about an document.+data DocInfo a = DocInfo + { document :: (Document a) -- ^ The document itself.+ , docScore :: Score -- ^ The score for the document (initial score for all documents is @0.0@).+ }+ deriving (Eq, Show)++-- | Information about a word.+data WordInfo = WordInfo + { terms :: Terms -- ^ The search terms that led to this very word.+ , wordScore :: Score -- ^ The frequency of the word in the document for a context.+ }+ deriving (Eq, Show)++-- | A mapping from a document to it's score and the contexts where it was found.+type DocHits a = DocIdMap (DocInfo a, DocContextHits)++-- | A mapping from a context to the words of the document that were found in this context.+type DocContextHits = Map Context DocWordHits++-- | A mapping from a word of the document in a specific context to it's positions.+type DocWordHits = Map Word Positions++-- | A mapping from a word to it's score and the contexts where it was found.+type WordHits = Map Word (WordInfo, WordContextHits)++-- | A mapping from a context to the documents that contain the word that were found in this context.+type WordContextHits = Map Context WordDocHits++-- | A mapping from a document containing the word to the positions of the word.+type WordDocHits = Occurrences++-- | The score of a hit (either a document hit or a word hit).+type Score = Float++-- | The original search terms entered by the user.+type Terms = [String]++-- ----------------------------------------------------------------------------++instance Binary a => Binary (Result a) where+ put (Result dh wh) = put dh >> put wh+ get = liftM2 Result get get++instance Binary a => Binary (DocInfo a) where+ put (DocInfo d s) = put d >> put s+ get = liftM2 DocInfo get get++instance Binary WordInfo where+ put (WordInfo t s) = put t >> put s+ get = liftM2 WordInfo get get++instance NFData a => NFData (Result a) where+ rnf (Result dh wh) = rnf dh `seq` rnf wh++instance NFData a => NFData (DocInfo a) where+ rnf (DocInfo d s) = rnf d `seq` rnf s++instance NFData WordInfo where+ rnf (WordInfo t s) = rnf t `seq` rnf s++instance XmlPickler a => XmlPickler (Result a) where+ xpickle = xpElem "result" $ + xpWrap ( \ (dh, wh) -> Result dh wh+ , \ (Result dh wh) -> (dh, wh)+ ) (xpPair xpDocHits xpWordHits)++instance XmlPickler a => XmlPickler (DocInfo a) where+ xpickle = xpWrap ( \ (d, s) -> DocInfo d s+ , \ (DocInfo d s) -> (d, s)+ ) xpDocInfo'+ where+ xpDocInfo' = xpPair xpickle (xpAttr "score" xpPrim)++instance XmlPickler WordInfo where+ xpickle = xpWrap ( \ (t, s) -> WordInfo t s+ , \ (WordInfo t s) -> (t, s)+ ) xpWordInfo+ where+ xpWordInfo = xpPair (xpAttr "term" xpTerms)+ (xpAttr "score" xpPrim)+ xpTerms = xpWrap (split ",", join ",") xpText0++-- ----------------------------------------------------------------------------++-- | The XML pickler for the document hits. Will be sorted by score.+xpDocHits :: XmlPickler a => PU (DocHits a)+xpDocHits = xpElem "dochits" $+ xpWrap ( fromListDocIdMap+ , toListSorted+ ) (xpList xpDocHit)+ where+ toListSorted = L.sortBy (compare `on` (docScore . fst . snd)) . toListDocIdMap -- Sort by score+ xpDocHit = xpElem "doc" $+ xpPair (xpAttr "idref" xpDocId)+ (xpPair xpickle xpDocContextHits)++-- | The XML pickler for the contexts in which the documents were found.+xpDocContextHits :: PU DocContextHits+xpDocContextHits = xpWrap (M.fromList, M.toList) $+ xpList xpDocContextHit+ where+ xpDocContextHit = xpElem "context" $+ xpPair (xpAttr "name" xpText) xpDocWordHits++-- | The XML pickler for the words and positions found in a document.+xpDocWordHits :: PU DocWordHits+xpDocWordHits = xpWrap (M.fromList, M.toList) (xpList xpDocWordHit)+ where+ xpDocWordHit = xpElem "word" $+ xpPair (xpAttr "w" xpText) xpPositions++-- | The XML pickler for the word hits. Will be sorted alphabetically by the words.+xpWordHits :: PU WordHits+xpWordHits = xpElem "wordhits" $+ xpWrap (M.fromList, toListSorted) $+ xpList xpWordHit+ where+ toListSorted = L.sortBy (compare `on` fst) . M.toList -- Sort by word+ xpWordHit = xpElem "word" $+ xpPair (xpAttr "w" xpText)+ (xpPair xpickle xpWordContextHits)++-- | The XML pickler for the contexts in which the words were found.+xpWordContextHits :: PU WordContextHits+xpWordContextHits = xpWrap (M.fromList, M.toList) $+ xpList xpWordContextHit+ where+ xpWordContextHit = xpElem "context" $+ xpPair (xpAttr "name" xpText) xpWordDocHits++-- | The XML pickler for the documents and positions where the word occurs (reusing existing pickler).+xpWordDocHits :: PU WordDocHits+xpWordDocHits = xpOccurrences++-- ----------------------------------------------------------------------------++-- | Create an empty result.+emptyResult :: Result a+emptyResult = Result emptyDocIdMap M.empty++-- | Query the number of documents in a result.+sizeDocHits :: Result a -> Int+sizeDocHits = sizeDocIdMap . docHits++-- | Query the number of documents in a result.+sizeWordHits :: Result a -> Int+sizeWordHits = M.size . wordHits++-- | Query the maximum score of the documents.+maxScoreDocHits :: Result a -> Score+maxScoreDocHits = (foldDocIdMap (\(di, _) r -> max (docScore di) r) 0.0) . docHits++-- | Query the maximum score of the words.+maxScoreWordHits :: Result a -> Score+maxScoreWordHits = (M.fold (\(wi, _) r -> max (wordScore wi) r) 0.0) . wordHits++-- | Test if the result contains anything.+null :: Result a -> Bool+null = nullDocIdMap . docHits++-- | Set the score in a document info.+setDocScore :: Score -> DocInfo a -> DocInfo a+setDocScore s (DocInfo d _)+ = DocInfo d s++-- | Set the score in a word info.+setWordScore :: Score -> WordInfo -> WordInfo+setWordScore s (WordInfo t _)+ = WordInfo t s++-- | Extract all documents from a result+getDocuments :: Result a -> [Document a]+getDocuments r = map (document . fst . snd) $+ toListDocIdMap (docHits r)++-- ----------------------------------------------------------------------------
+ src/Holumbus/Utility.hs view
@@ -0,0 +1,168 @@+-- ----------------------------------------------------------------------------++{- |+ Module : Holumbus.Utility+ Copyright : Copyright (C) 2008 Timo B. Huebel+ License : MIT++ Maintainer : Timo B. Huebel (tbh@holumbus.org)+ Stability : experimental+ Portability: portable+ Version : 0.1++ Small utility functions which are probably useful somewhere else, too.++-}++-- ----------------------------------------------------------------------------++module Holumbus.Utility where+++import Control.Exception (bracket)++import Data.Binary+import qualified Data.ByteString.Lazy as B+import Data.Char+import qualified Data.List as L++import Numeric ( showHex )++import System.IO++import Text.XML.HXT.Core++-- ------------------------------------------------------------++-- | Split a string into seperate strings at a specific character sequence.++split :: Eq a => [a] -> [a] -> [[a]]+split _ [] = [[]] +split at w@(x:xs) = maybe ((x:r):rs) ((:) [] . split at) (L.stripPrefix at w)+ where (r:rs) = split at xs+ +-- | Join with a seperating character sequence.++join :: Eq a => [a] -> [[a]] -> [a]+join = L.intercalate++-- | Removes leading and trailing whitespace from a string.++strip :: String -> String+strip = stripWith isSpace++-- | Removes leading whitespace from a string.++stripl :: String -> String+stripl = dropWhile isSpace++-- | Removes trailing whitespace from a string.++stripr :: String -> String+stripr = reverse . dropWhile isSpace . reverse++-- | Strip leading and trailing elements matching a predicate.++stripWith :: (a -> Bool) -> [a] -> [a]+stripWith f = reverse . dropWhile f . reverse . dropWhile f++-- | found on the haskell cafe mailing list+-- (<http://www.haskell.org/pipermail/haskell-cafe/2008-April/041970.html>).+-- Depends on bytestring >= 0.9.0.4 (?) ++strictDecodeFile :: Binary a => FilePath -> IO a+strictDecodeFile f =+ bracket (openBinaryFile f ReadMode)+ hClose+ $ \h -> do c <- B.hGetContents h+ return $! decode c ++-- | partition the list of input data into a list of input data lists of+-- approximately the same specified length++partitionListByLength :: Int -> [a] -> [[a]]+partitionListByLength _ [] = []+partitionListByLength count l = [take count l] ++ (partitionListByLength count (drop count l)) ++-- | partition the list of input data into a list of a specified number of input data lists with +-- approximately the same length++partitionListByCount :: Int -> [a] -> [[a]]+partitionListByCount sublistCount list = partition sublistCount list+ where+ partition 0 _ = []+ partition sublists l + = let next = ((length l) `div` sublists)+ in if next == 0 then [l]+ else [take next l] ++ partition (sublists -1) (drop next l)++-- | Escapes non-alphanumeric or space characters in a String++escape :: String -> String +escape [] = []+escape (c:cs)+ = if isAlphaNum c || isSpace c + then c : escape cs+ else '%' : showHex (fromEnum c) "" ++ escape cs+ +-- ------------------------------------------------------------+-- | Compute the base of a webpage+-- stolen from Uwe Schmidt, http:\/\/www.haskell.org\/haskellwiki\/HXT++computeDocBase :: ArrowXml a => a XmlTree String+computeDocBase+ = ( ( ( this+ /> hasName "html"+ /> hasName "head"+ /> hasName "base"+ >>> getAttrValue "href"+ )+ &&&+ getAttrValue "transfer-URI"+ )+ >>> expandURI+ )+ `orElse`+ getAttrValue "transfer-URI" + +traceOffset :: Int+traceOffset = 3++trcMsg :: String -> IO ()+trcMsg m = hPutStrLn stderr ('-':"- (0) " ++ m)++-- ------------------------------------------------------------+--+-- simple and usefull access arrows++getByPath :: ArrowXml a => [String] -> a XmlTree XmlTree+getByPath = seqA . map (\ n -> getChildren >>> hasName n)++robotsNo :: String -> LA XmlTree XmlTree+robotsNo what = none+ `when`+ ( getByPath ["html", "head", "meta"]+ >>>+ hasAttrValue "name" ( map toUpper+ >>>+ (== "ROBOTS")+ )+ >>>+ getAttrValue0 "content"+ >>>+ isA ( map (toUpper >>> (\ x -> if isLetter x then x else ' '))+ >>>+ words+ >>>+ (what `elem`)+ )+ ) ++robotsNoIndex :: ArrowXml a => a XmlTree XmlTree+robotsNoIndex = fromLA $ robotsNo "NOINDEX"++robotsNoFollow :: ArrowXml a => a XmlTree XmlTree+robotsNoFollow = fromLA $ robotsNo "NOFOLLOW"++-- ------------------------------------------------------------+