diff --git a/Data/SearchEngine.hs b/Data/SearchEngine.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine.hs @@ -0,0 +1,386 @@ +{-# LANGUAGE BangPatterns, NamedFieldPuns, RecordWildCards #-} + +module Data.SearchEngine ( + + -- * Basic interface + + -- ** Querying + Term, + query, + + -- ** Making a search engine instance + initSearchEngine, + SearchEngine, + SearchConfig(..), + SearchRankParameters(..), + BM25F.FeatureFunction(..), + + -- ** Helper type for non-term features + NoFeatures, + noFeatures, + + -- ** Managing documents to be searched + insertDoc, + insertDocs, + deleteDoc, + + -- * Explain mode for query result rankings + queryExplain, + BM25F.Explanation(..), + setRankParams, + + -- * Internal sanity check + invariant, + ) where + +import Data.SearchEngine.SearchIndex (SearchIndex, Term, TermId) +import qualified Data.SearchEngine.SearchIndex as SI +import Data.SearchEngine.DocIdSet (DocIdSet, DocId) +import qualified Data.SearchEngine.DocIdSet as DocIdSet +import Data.SearchEngine.DocTermIds (DocTermIds) +import qualified Data.SearchEngine.DocTermIds as DocTermIds +import Data.SearchEngine.DocFeatVals (DocFeatVals) +import qualified Data.SearchEngine.DocFeatVals as DocFeatVals +import qualified Data.SearchEngine.BM25F as BM25F + +import Data.Ix +import Data.Array.Unboxed +import Data.List +import Data.Function +import Data.Maybe + +------------------- +-- Doc layer +-- +-- That is, at the layer of documents, so covering the issues of: +-- - inserting/removing whole documents +-- - documents having multiple fields +-- - documents having multiple terms +-- - transformations (case-fold/normalisation/stemming) on the doc terms +-- - transformations on the search terms +-- + +data SearchConfig doc key field feature = SearchConfig { + documentKey :: doc -> key, + extractDocumentTerms :: doc -> field -> [Term], + transformQueryTerm :: Term -> field -> Term, + documentFeatureValue :: doc -> feature -> Float + } + +data SearchRankParameters field feature = SearchRankParameters { + paramK1 :: !Float, + paramB :: field -> Float, + paramFieldWeights :: field -> Float, + paramFeatureWeights :: feature -> Float, + paramFeatureFunctions :: feature -> BM25F.FeatureFunction, + paramResultsetSoftLimit :: !Int, + paramResultsetHardLimit :: !Int + } + +data SearchEngine doc key field feature = SearchEngine { + searchIndex :: !(SearchIndex key field feature), + searchConfig :: !(SearchConfig doc key field feature), + searchRankParams :: !(SearchRankParameters field feature), + + -- cached info + sumFieldLengths :: !(UArray field Int), + bm25Context :: BM25F.Context TermId field feature + } + +initSearchEngine :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchConfig doc key field feature -> + SearchRankParameters field feature -> + SearchEngine doc key field feature +initSearchEngine config params = + cacheBM25Context + SearchEngine { + searchIndex = SI.emptySearchIndex, + searchConfig = config, + searchRankParams = params, + sumFieldLengths = listArray (minBound, maxBound) (repeat 0), + bm25Context = undefined + } + +setRankParams :: SearchRankParameters field feature -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +setRankParams params@SearchRankParameters{..} se = + se { + searchRankParams = params, + bm25Context = (bm25Context se) { + BM25F.paramK1 = paramK1, + BM25F.paramB = paramB, + BM25F.fieldWeight = paramFieldWeights, + BM25F.featureWeight = paramFeatureWeights, + BM25F.featureFunction = paramFeatureFunctions + } + } + +invariant :: (Ord key, Ix field, Bounded field) => + SearchEngine doc key field feature -> Bool +invariant SearchEngine{searchIndex} = + SI.invariant searchIndex +-- && check caches + +cacheBM25Context :: Ix field => + SearchEngine doc key field feature -> + SearchEngine doc key field feature +cacheBM25Context + se@SearchEngine { + searchRankParams = SearchRankParameters{..}, + searchIndex, + sumFieldLengths + } + = se { bm25Context = bm25Context' } + where + bm25Context' = BM25F.Context { + BM25F.numDocsTotal = SI.docCount searchIndex, + BM25F.avgFieldLength = \f -> fromIntegral (sumFieldLengths ! f) + / fromIntegral (SI.docCount searchIndex), + BM25F.numDocsWithTerm = DocIdSet.size . SI.lookupTermId searchIndex, + BM25F.paramK1 = paramK1, + BM25F.paramB = paramB, + BM25F.fieldWeight = paramFieldWeights, + BM25F.featureWeight = paramFeatureWeights, + BM25F.featureFunction = paramFeatureFunctions + } + +updateCachedFieldLengths :: (Ix field, Bounded field) => + Maybe (DocTermIds field) -> Maybe (DocTermIds field) -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +updateCachedFieldLengths Nothing (Just newDoc) se@SearchEngine{sumFieldLengths} = + se { + sumFieldLengths = + array (bounds sumFieldLengths) + [ (i, n + DocTermIds.fieldLength newDoc i) + | (i, n) <- assocs sumFieldLengths ] + } +updateCachedFieldLengths (Just oldDoc) (Just newDoc) se@SearchEngine{sumFieldLengths} = + se { + sumFieldLengths = + array (bounds sumFieldLengths) + [ (i, n - DocTermIds.fieldLength oldDoc i + + DocTermIds.fieldLength newDoc i) + | (i, n) <- assocs sumFieldLengths ] + } +updateCachedFieldLengths (Just oldDoc) Nothing se@SearchEngine{sumFieldLengths} = + se { + sumFieldLengths = + array (bounds sumFieldLengths) + [ (i, n - DocTermIds.fieldLength oldDoc i) + | (i, n) <- assocs sumFieldLengths ] + } +updateCachedFieldLengths Nothing Nothing se = se + +insertDocs :: (Ord key, Ix field, Bounded field, Ix feature, Bounded feature) => + [doc] -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +insertDocs docs se = foldl' (\se' doc -> insertDoc doc se') se docs + +insertDoc :: (Ord key, Ix field, Bounded field, Ix feature, Bounded feature) => + doc -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +insertDoc doc se@SearchEngine{ searchConfig = SearchConfig { + documentKey, + extractDocumentTerms, + documentFeatureValue + } + , searchIndex } = + let key = documentKey doc + searchIndex' = SI.insertDoc key (extractDocumentTerms doc) + (documentFeatureValue doc) + searchIndex + oldDoc = SI.lookupDocKey searchIndex key + newDoc = SI.lookupDocKey searchIndex' key + + in cacheBM25Context $ + updateCachedFieldLengths oldDoc newDoc $ + se { searchIndex = searchIndex' } + +deleteDoc :: (Ord key, Ix field, Bounded field) => + key -> + SearchEngine doc key field feature -> + SearchEngine doc key field feature +deleteDoc key se@SearchEngine{searchIndex} = + let searchIndex' = SI.deleteDoc key searchIndex + oldDoc = SI.lookupDocKey searchIndex key + + in cacheBM25Context $ + updateCachedFieldLengths oldDoc Nothing $ + se { searchIndex = searchIndex' } + +query :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [Term] -> [key] +query se@SearchEngine{ searchIndex, + searchConfig = SearchConfig{transformQueryTerm}, + searchRankParams = SearchRankParameters{..} } + terms = + + let -- Start by transforming/normalising all the query terms. + -- This can be done differently for each field we search by. + lookupTerms :: [Term] + lookupTerms = [ term' + | term <- terms + , let transformForField = transformQueryTerm term + , term' <- nub [ transformForField field + | field <- range (minBound, maxBound) ] + ] + + -- Then we look up all the normalised terms in the index. + rawresults :: [Maybe (TermId, DocIdSet)] + rawresults = map (SI.lookupTerm searchIndex) lookupTerms + + -- For the terms that occur in the index, this gives us the term's id + -- and the set of documents that the term occurs in. + termids :: [TermId] + docidsets :: [DocIdSet] + (termids, docidsets) = unzip (catMaybes rawresults) + + -- We looked up the documents that *any* of the term occur in (not all) + -- so this could be rather a lot of docs if the user uses a few common + -- terms. Scoring these result docs is a non-trivial cost so we want to + -- limit the number that we have to score. The standard trick is to + -- consider the doc sets in the order of size, smallest to biggest. Once + -- we have gone over a certain threshold of docs then don't bother with + -- the doc sets for the remaining terms. This tends to work because the + -- scoring gives lower weight to terms that occur in many documents. + unrankedResults :: DocIdSet + unrankedResults = pruneRelevantResults + paramResultsetSoftLimit + paramResultsetHardLimit + docidsets + + --TODO: technically this isn't quite correct. Because each field can + -- be normalised differently, we can end up with different termids for + -- the same original search term, and then we score those as if they + -- were different terms, which makes a difference when the term appears + -- in multiple fields (exactly the case BM25F is supposed to deal with). + -- What we ought to have instead is an Array (Int, field) TermId, and + -- make the scoring use the appropriate termid for each field, but to + -- consider them the "same" term. + in rankResults se termids (DocIdSet.toList unrankedResults) + +rankResults :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> [DocId] -> [key] +rankResults se@SearchEngine{searchIndex} queryTerms docids = + map snd + $ sortBy (flip compare `on` fst) + [ (relevanceScore se queryTerms doctermids docfeatvals, dockey) + | docid <- docids + , let (dockey, doctermids, docfeatvals) = SI.lookupDocId searchIndex docid ] + +relevanceScore :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> DocTermIds field -> DocFeatVals feature -> Float +relevanceScore SearchEngine{bm25Context} queryTerms doctermids docfeatvals = + BM25F.score bm25Context doc queryTerms + where + doc = indexDocToBM25Doc doctermids docfeatvals + +indexDocToBM25Doc :: (Ix field, Bounded field, Ix feature, Bounded feature) => + DocTermIds field -> + DocFeatVals feature -> + BM25F.Doc TermId field feature +indexDocToBM25Doc doctermids docfeatvals = + BM25F.Doc { + BM25F.docFieldLength = DocTermIds.fieldLength doctermids, + BM25F.docFieldTermFrequency = DocTermIds.fieldTermCount doctermids, + BM25F.docFeatureValue = DocFeatVals.featureValue docfeatvals + } + +pruneRelevantResults :: Int -> Int -> [DocIdSet] -> DocIdSet +pruneRelevantResults softLimit hardLimit = + -- Look at the docsets starting with the smallest ones. Smaller docsets + -- correspond to the rarer terms, which are the ones that score most highly. + go DocIdSet.empty . sortBy (compare `on` DocIdSet.size) + where + go !acc [] = acc + go !acc (d:ds) + -- If this is the first one, we add it anyway, otherwise we're in + -- danger of returning no results at all. + | DocIdSet.null acc = go d ds + -- We consider the size our docset would be if we add this extra one... + -- If it puts us over the hard limit then stop. + | size > hardLimit = acc + -- If it puts us over soft limit then we add it and stop + | size > softLimit = DocIdSet.union acc d + -- Otherwise we can add it and carry on to consider the remainder + | otherwise = go (DocIdSet.union acc d) ds + where + size = DocIdSet.size acc + DocIdSet.size d + +----------------------------- + +queryExplain :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [Term] -> [(BM25F.Explanation field feature Term, key)] +queryExplain se@SearchEngine{ searchIndex, + searchConfig = SearchConfig{transformQueryTerm}, + searchRankParams = SearchRankParameters{..} } + terms = + + -- See 'query' above for explanation. Really we ought to combine them. + let lookupTerms :: [Term] + lookupTerms = [ term' + | term <- terms + , let transformForField = transformQueryTerm term + , term' <- nub [ transformForField field + | field <- range (minBound, maxBound) ] + ] + + rawresults :: [Maybe (TermId, DocIdSet)] + rawresults = map (SI.lookupTerm searchIndex) lookupTerms + + termids :: [TermId] + docidsets :: [DocIdSet] + (termids, docidsets) = unzip (catMaybes rawresults) + + unrankedResults :: DocIdSet + unrankedResults = pruneRelevantResults + paramResultsetSoftLimit + paramResultsetHardLimit + docidsets + + in rankExplainResults se termids (DocIdSet.toList unrankedResults) + +rankExplainResults :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> + [DocId] -> + [(BM25F.Explanation field feature Term, key)] +rankExplainResults se@SearchEngine{searchIndex} queryTerms docids = + sortBy (flip compare `on` (BM25F.overallScore . fst)) + [ (explainRelevanceScore se queryTerms doctermids docfeatvals, dockey) + | docid <- docids + , let (dockey, doctermids, docfeatvals) = SI.lookupDocId searchIndex docid ] + +explainRelevanceScore :: (Ix field, Bounded field, Ix feature, Bounded feature) => + SearchEngine doc key field feature -> + [TermId] -> + DocTermIds field -> + DocFeatVals feature -> + BM25F.Explanation field feature Term +explainRelevanceScore SearchEngine{bm25Context, searchIndex} + queryTerms doctermids docfeatvals = + fmap (SI.getTerm searchIndex) (BM25F.explain bm25Context doc queryTerms) + where + doc = indexDocToBM25Doc doctermids docfeatvals + +----------------------------- + +data NoFeatures = NoFeatures + deriving (Eq, Ord, Bounded) + +instance Ix NoFeatures where + range _ = [] + inRange _ _ = False + index _ _ = -1 + +noFeatures :: NoFeatures -> a +noFeatures _ = error "noFeatures" + diff --git a/Data/SearchEngine/BM25F.hs b/Data/SearchEngine/BM25F.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine/BM25F.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | An implementation of BM25F ranking. See: +-- +-- * A quick overview: +-- +-- * /The Probabilistic Relevance Framework: BM25 and Beyond/ +-- +-- +-- * /An Introduction to Information Retrieval/ +-- +-- +module Data.SearchEngine.BM25F ( + -- * The ranking function + score, + Context(..), + FeatureFunction(..), + Doc(..), + + -- * Explaining the score + Explanation(..), + explain, + ) where + +import Data.Ix + +data Context term field feature = Context { + numDocsTotal :: !Int, + avgFieldLength :: field -> Float, + numDocsWithTerm :: term -> Int, + paramK1 :: !Float, + paramB :: field -> Float, + -- consider minimum length to prevent massive B bonus? + fieldWeight :: field -> Float, + featureWeight :: feature -> Float, + featureFunction :: feature -> FeatureFunction + } + +data Doc term field feature = Doc { + docFieldLength :: field -> Int, + docFieldTermFrequency :: field -> term -> Int, + docFeatureValue :: feature -> Float + } + + +-- | The BM25F score for a document for a given set of terms. +-- +score :: (Ix field, Bounded field, Ix feature, Bounded feature) => + Context term field feature -> + Doc term field feature -> [term] -> Float +score ctx doc terms = + sum (map (weightedTermScore ctx doc) terms) + + sum (map (weightedNonTermScore ctx doc) features) + + where + features = range (minBound, maxBound) + + +weightedTermScore :: (Ix field, Bounded field) => + Context term field feature -> + Doc term field feature -> term -> Float +weightedTermScore ctx doc t = + weightIDF ctx t * tf' + / (k1 + tf') + where + tf' = weightedDocTermFrequency ctx doc t + k1 = paramK1 ctx + + +weightIDF :: Context term field feature -> term -> Float +weightIDF ctx t = + log ((n - n_t + 0.5) / (n_t + 0.5)) + where + n = fromIntegral (numDocsTotal ctx) + n_t = fromIntegral (numDocsWithTerm ctx t) + + +weightedDocTermFrequency :: (Ix field, Bounded field) => + Context term field feature -> + Doc term field feature -> term -> Float +weightedDocTermFrequency ctx doc t = + sum [ w_f * tf_f / _B_f + | field <- range (minBound, maxBound) + , let w_f = fieldWeight ctx field + tf_f = fromIntegral (docFieldTermFrequency doc field t) + _B_f = lengthNorm ctx doc field + ] + + +lengthNorm :: Context term field feature -> + Doc term field feature -> field -> Float +lengthNorm ctx doc field = + (1-b_f) + b_f * sl_f / avgsl_f + where + b_f = paramB ctx field + sl_f = fromIntegral (docFieldLength doc field) + avgsl_f = avgFieldLength ctx field + + +weightedNonTermScore :: (Ix feature, Bounded feature) => + Context term field feature -> + Doc term field feature -> feature -> Float +weightedNonTermScore ctx doc feature = + w_f * _V_f f_f + where + w_f = featureWeight ctx feature + _V_f = applyFeatureFunction (featureFunction ctx feature) + f_f = docFeatureValue doc feature + + +data FeatureFunction + = LogarithmicFunction Float -- ^ @log (\lambda_i + f_i)@ + | RationalFunction Float -- ^ @f_i / (\lambda_i + f_i)@ + | SigmoidFunction Float Float -- ^ @1 / (\lambda + exp(-(\lambda' * f_i))@ + +applyFeatureFunction :: FeatureFunction -> (Float -> Float) +applyFeatureFunction (LogarithmicFunction p1) = \fi -> log (p1 + fi) +applyFeatureFunction (RationalFunction p1) = \fi -> fi / (p1 + fi) +applyFeatureFunction (SigmoidFunction p1 p2) = \fi -> 1 / (p1 + exp (-fi * p2)) + + +------------------ +-- Explanation +-- + +-- | A breakdown of the BM25F score, to explain somewhat how it relates to +-- the inputs, and so you can compare the scores of different documents. +-- +data Explanation field feature term = Explanation { + -- | The overall score is the sum of the 'termScores', 'positionScore' + -- and 'nonTermScore' + overallScore :: Float, + + -- | There is a score contribution from each query term. This is the + -- score for the term across all fields in the document (but see + -- 'termFieldScores'). + termScores :: [(term, Float)], +{- + -- | There is a score contribution for positional information. Terms + -- appearing in the document close together give a bonus. + positionScore :: [(field, Float)], +-} + -- | The document can have an inate bonus score independent of the terms + -- in the query. For example this might be a popularity score. + nonTermScores :: [(feature, Float)], + + -- | This does /not/ contribute to the 'overallScore'. It is an + -- indication of how the 'termScores' relates to per-field scores. + -- Note however that the term score for all fields is /not/ simply + -- sum of the per-field scores. The point of the BM25F scoring function + -- is that a linear combination of per-field scores is wrong, and BM25F + -- does a more cunning non-linear combination. + -- + -- However, it is still useful as an indication to see scores for each + -- field for a term, to see how the compare. + -- + termFieldScores :: [(term, [(field, Float)])] + } + deriving Show + +instance Functor (Explanation field feature) where + fmap f e@Explanation{..} = + e { + termScores = [ (f t, s) | (t, s) <- termScores ], + termFieldScores = [ (f t, fs) | (t, fs) <- termFieldScores ] + } + +explain :: (Ix field, Bounded field, Ix feature, Bounded feature) => + Context term field feature -> + Doc term field feature -> [term] -> Explanation field feature term +explain ctx doc ts = + Explanation {..} + where + overallScore = sum (map snd termScores) +-- + sum (map snd positionScore) + + sum (map snd nonTermScores) + termScores = [ (t, weightedTermScore ctx doc t) | t <- ts ] +-- positionScore = [ (f, 0) | f <- range (minBound, maxBound) ] + nonTermScores = [ (feature, weightedNonTermScore ctx doc feature) + | feature <- range (minBound, maxBound) ] + + termFieldScores = + [ (t, fieldScores) + | t <- ts + , let fieldScores = + [ (f, weightedTermScore ctx' doc t) + | f <- range (minBound, maxBound) + , let ctx' = ctx { fieldWeight = fieldWeightOnly f } + ] + ] + fieldWeightOnly f f' | sameField f f' = fieldWeight ctx f' + | otherwise = 0 + + sameField f f' = index (minBound, maxBound) f + == index (minBound, maxBound) f' diff --git a/Data/SearchEngine/DocFeatVals.hs b/Data/SearchEngine/DocFeatVals.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine/DocFeatVals.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +module Data.SearchEngine.DocFeatVals ( + DocFeatVals, + featureValue, + create, + ) where + +import Data.SearchEngine.DocTermIds (vecIndexIx, vecCreateIx) +import Data.Vector (Vector) +import Data.Ix (Ix) + + +-- | Storage for the non-term feature values i a document. +-- +newtype DocFeatVals feature = DocFeatVals (Vector Float) + deriving (Show) + +featureValue :: (Ix feature, Bounded feature) => DocFeatVals feature -> feature -> Float +featureValue (DocFeatVals featVec) = vecIndexIx featVec + +create :: (Ix feature, Bounded feature) => + (feature -> Float) -> DocFeatVals feature +create docFeatVals = + DocFeatVals (vecCreateIx docFeatVals) + diff --git a/Data/SearchEngine/DocIdSet.hs b/Data/SearchEngine/DocIdSet.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine/DocIdSet.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +module Data.SearchEngine.DocIdSet ( + DocId, + DocIdSet, + null, + size, + empty, + singleton, + fromList, + toList, + toSet, + insert, + delete, + union, + invariant, + ) where + +import Data.Word +import qualified Data.Vector.Unboxed as Vec +import qualified Data.Vector.Unboxed.Mutable as MVec +import qualified Data.Vector.Generic.Base as VecGen +import qualified Data.Vector.Unboxed.Base as VecBase +import qualified Data.Vector.Generic.Mutable as VecMut +import Control.Monad.ST +import Data.Set (Set) +import qualified Data.Set as Set + +import Prelude hiding (null) + +--import Test.QuickCheck +--import qualified Data.List as List + +newtype DocId = DocId Word32 + deriving (Eq, Ord, Show, Enum, Bounded, Vec.Unbox, + VecGen.Vector VecBase.Vector, + VecMut.MVector VecBase.MVector) + +newtype DocIdSet = DocIdSet (Vec.Vector DocId) + deriving (Eq, Show) + +-- represented as a sorted sequence of ids +invariant :: DocIdSet -> Bool +invariant (DocIdSet vec) = + strictlyAscending (Vec.toList vec) + where + strictlyAscending (a:xs@(b:_)) = a < b && strictlyAscending xs + strictlyAscending _ = True + + +size :: DocIdSet -> Int +size (DocIdSet vec) = Vec.length vec + +null :: DocIdSet -> Bool +null (DocIdSet vec) = Vec.null vec + +empty :: DocIdSet +empty = DocIdSet Vec.empty + +singleton :: DocId -> DocIdSet +singleton = DocIdSet . Vec.singleton + +fromList :: [DocId] -> DocIdSet +fromList = DocIdSet . Vec.fromList . Set.toAscList . Set.fromList + +toList :: DocIdSet -> [DocId] +toList (DocIdSet vec) = Vec.toList vec + +toSet :: DocIdSet -> Set DocId +toSet (DocIdSet vec) = Set.fromDistinctAscList (Vec.toList vec) + +insert :: DocId -> DocIdSet -> DocIdSet +insert x (DocIdSet vec) = + case binarySearch vec 0 (Vec.length vec - 1) x of + (_, True) -> DocIdSet vec + (i, False) -> case Vec.splitAt i vec of + (before, after) -> + DocIdSet (Vec.concat [before, Vec.singleton x, after]) + +delete :: DocId -> DocIdSet -> DocIdSet +delete x (DocIdSet vec) = + case binarySearch vec 0 (Vec.length vec - 1) x of + (_, False) -> DocIdSet vec + (i, True) -> case Vec.splitAt i vec of + (before, after) -> + DocIdSet (before Vec.++ Vec.tail after) + +binarySearch :: Vec.Vector DocId -> Int -> Int -> DocId -> (Int, Bool) +binarySearch vec !a !b !key + | a > b = (a, False) + | otherwise = + let mid = (a + b) `div` 2 + in case compare key (vec Vec.! mid) of + LT -> binarySearch vec a (mid-1) key + EQ -> (mid, True) + GT -> binarySearch vec (mid+1) b key + +union :: DocIdSet -> DocIdSet -> DocIdSet +union x y | null x = y + | null y = x +union (DocIdSet xs) (DocIdSet ys) = + DocIdSet (Vec.create (MVec.new sizeBound >>= writeMerged xs ys)) + where + sizeBound = Vec.length xs + Vec.length ys + +writeMerged :: Vec.Vector DocId -> Vec.Vector DocId -> + MVec.MVector s DocId -> ST s (MVec.MVector s DocId) +writeMerged xs0 ys0 out = do + i <- go xs0 ys0 0 + return $! MVec.take i out + where + go !xs !ys !i + | Vec.null xs = do Vec.copy (MVec.slice i (Vec.length ys) out) ys + return (i + Vec.length ys) + | Vec.null ys = do Vec.copy (MVec.slice i (Vec.length xs) out) xs + return (i + Vec.length xs) + | otherwise = let x = Vec.head xs; y = Vec.head ys + in case compare x y of + GT -> do MVec.write out i y + go xs (Vec.tail ys) (i+1) + EQ -> do MVec.write out i x + go (Vec.tail xs) (Vec.tail ys) (i+1) + LT -> do MVec.write out i x + go (Vec.tail xs) ys (i+1) + + +------------- +-- tests +-- +{- +instance Arbitrary DocIdSet where + arbitrary = fromList `fmap` (listOf arbitrary) + +instance Arbitrary DocId where + arbitrary = DocId `fmap` choose (0,15) + + +prop_insert :: DocIdSet -> DocId -> Bool +prop_insert dset x = + let dset' = insert x dset + in invariant dset && invariant dset' + && all (`member` dset') (x : toList dset) + +prop_delete :: DocIdSet -> DocId -> Bool +prop_delete dset x = + let dset' = DocIdSet.delete x dset + in invariant dset && invariant dset' + && all (`member` dset') (List.delete x (toList dset)) + && not (x `member` dset') + +prop_delete' :: DocIdSet -> Bool +prop_delete' dset = + all (prop_delete dset) (toList dset) + +prop_union :: DocIdSet -> DocIdSet -> Bool +prop_union dset1 dset2 = + let dset = union dset1 dset2 + dset' = fromList (List.union (toList dset1) (toList dset2)) + + in invariant dset && invariant dset' + && dset == dset' + +prop_union' :: DocIdSet -> DocIdSet -> Bool +prop_union' dset1 dset2 = + let dset = union dset1 dset2 + dset' = List.foldl' (\s i -> insert i s) dset1 (toList dset2) + dset'' = List.foldl' (\s i -> insert i s) dset2 (toList dset1) + in invariant dset && invariant dset' && invariant dset'' + && dset == dset' + && dset' == dset'' + +member :: DocId -> DocIdSet -> Bool +member x (DocIdSet vec) = + x `List.elem` Vec.toList vec +-} diff --git a/Data/SearchEngine/DocTermIds.hs b/Data/SearchEngine/DocTermIds.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine/DocTermIds.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +module Data.SearchEngine.DocTermIds ( + DocTermIds, + TermId, + fieldLength, + fieldTermCount, + fieldElems, + create, + vecIndexIx, + vecCreateIx, + ) where + +import Data.SearchEngine.TermBag (TermBag, TermId) +import qualified Data.SearchEngine.TermBag as TermBag + +import Data.Vector (Vector, (!)) +import qualified Data.Vector as Vec +import Data.Ix (Ix) +import qualified Data.Ix as Ix + + +-- | The 'TermId's for the 'Term's that occur in a document. Documents may have +-- multiple fields and the 'DocTerms' type holds them separately for each field. +-- +newtype DocTermIds field = DocTermIds (Vector TermBag) + deriving (Show) + +getField :: (Ix field, Bounded field) => DocTermIds field -> field -> TermBag +getField (DocTermIds fieldVec) = vecIndexIx fieldVec + +create :: (Ix field, Bounded field) => + (field -> [TermId]) -> DocTermIds field +create docTermIds = + DocTermIds (vecCreateIx (TermBag.fromList . docTermIds)) + +-- | The number of terms in a field within the document. +fieldLength :: (Ix field, Bounded field) => DocTermIds field -> field -> Int +fieldLength docterms field = + TermBag.size (getField docterms field) + +-- | The frequency of a particular term in a field within the document. +fieldTermCount :: (Ix field, Bounded field) => DocTermIds field -> field -> TermId -> Int +fieldTermCount docterms field termid = + TermBag.termCount (getField docterms field) termid + +fieldElems :: (Ix field, Bounded field) => DocTermIds field -> field -> [TermId] +fieldElems docterms field = + TermBag.elems (getField docterms field) + +--------------------------------- +-- Vector indexed by Ix Bounded +-- + +vecIndexIx :: (Ix ix, Bounded ix) => Vector a -> ix -> a +vecIndexIx vec ix = vec ! Ix.index (minBound, maxBound) ix + +vecCreateIx :: (Ix ix, Bounded ix) => (ix -> a) -> Vector a +vecCreateIx f = Vec.fromListN (Ix.rangeSize bounds) + [ y | ix <- Ix.range bounds, let !y = f ix ] + where + bounds = (minBound, maxBound) + diff --git a/Data/SearchEngine/SearchIndex.hs b/Data/SearchEngine/SearchIndex.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine/SearchIndex.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE BangPatterns, NamedFieldPuns #-} + +module Data.SearchEngine.SearchIndex ( + SearchIndex, + Term, + TermId, + DocId, + + emptySearchIndex, + insertDoc, + deleteDoc, + + docCount, + lookupTerm, + lookupTermId, + lookupDocId, + lookupDocKey, + + getTerm, + + invariant, + ) where + +import Data.SearchEngine.DocIdSet (DocIdSet, DocId) +import qualified Data.SearchEngine.DocIdSet as DocIdSet +import Data.SearchEngine.DocTermIds (DocTermIds, TermId, vecIndexIx, vecCreateIx) +import qualified Data.SearchEngine.DocTermIds as DocTermIds +import Data.SearchEngine.DocFeatVals (DocFeatVals) +import qualified Data.SearchEngine.DocFeatVals as DocFeatVals + +import Data.Ix (Ix) +import qualified Data.Ix as Ix +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Set as Set +import Data.Text (Text) +import Data.List (foldl') + +import Control.Exception (assert) + +-- | Terms are short strings, usually whole words. +-- +type Term = Text + +-- | The search index is essentially a many-to-many mapping between documents +-- and terms. Each document contains many terms and each term occurs in many +-- documents. It is a bidirectional mapping as we need to support lookups in +-- both directions. +-- +-- Documents are identified by a key (in Ord) while terms are text values. +-- Inside the index however we assign compact numeric ids to both documents and +-- terms. The advantage of this is a much more compact in-memory representation +-- and the disadvantage is greater complexity. In particular it means we have +-- to manage bidirectional mappings between document keys and ids, and between +-- terms and term ids. +-- +-- So the mappings we maintain can be depicted as: +-- +-- > Term <-- 1:1 --> TermId +-- > ^ +-- > | +-- > many:many +-- > | +-- > v +-- > DocKey <-- 1:1 --> DocId +-- +-- For efficiency, these details are exposed in the interface. In particular +-- the mapping from TermId to many DocIds is exposed via a 'DocIdSet', +-- and the mapping from DocIds to TermIds is exposed via 'DocTermIds'. +-- +data SearchIndex key field feature = SearchIndex { + -- the indexes + termMap :: !(Map Term TermInfo), + termIdMap :: !(IntMap Term), + docIdMap :: !(IntMap (DocInfo key field feature)), + docKeyMap :: !(Map key DocId), + + -- auto-increment key counters + nextTermId :: TermId, + nextDocId :: DocId + } + deriving Show + +data TermInfo = TermInfo !TermId !DocIdSet + deriving Show + +data DocInfo key field feature = DocInfo !key !(DocTermIds field) + !(DocFeatVals feature) + deriving Show + + +----------------------- +-- SearchIndex basics +-- + +emptySearchIndex :: SearchIndex key field feature +emptySearchIndex = + SearchIndex + Map.empty + IntMap.empty + IntMap.empty + Map.empty + minBound + minBound + +checkInvariant :: (Ord key, Ix field, Bounded field) => + SearchIndex key field feature -> SearchIndex key field feature +checkInvariant si = assert (invariant si) si + +invariant :: (Ord key, Ix field, Bounded field) => + SearchIndex key field feature -> Bool +invariant SearchIndex{termMap, termIdMap, docKeyMap, docIdMap} = + and [ IntMap.lookup (fromEnum termId) termIdMap == Just term + | (term, (TermInfo termId _)) <- Map.assocs termMap ] + && and [ case Map.lookup term termMap of + Just (TermInfo termId' _) -> toEnum termId == termId' + Nothing -> False + | (termId, term) <- IntMap.assocs termIdMap ] + && and [ case IntMap.lookup (fromEnum docId) docIdMap of + Just (DocInfo docKey' _ _) -> docKey == docKey' + Nothing -> False + | (docKey, docId) <- Map.assocs docKeyMap ] + && and [ Map.lookup docKey docKeyMap == Just (toEnum docId) + | (docId, DocInfo docKey _ _) <- IntMap.assocs docIdMap ] + && and [ DocIdSet.invariant docIdSet + | (_term, (TermInfo _ docIdSet)) <- Map.assocs termMap ] + && and [ any (\field -> DocTermIds.fieldTermCount docterms field termId > 0) fields + | (_term, (TermInfo termId docIdSet)) <- Map.assocs termMap + , docId <- DocIdSet.toList docIdSet + , let DocInfo _ docterms _ = docIdMap IntMap.! fromEnum docId ] + && and [ IntMap.member (fromEnum termid) termIdMap + | (_docId, DocInfo _ docTerms _) <- IntMap.assocs docIdMap + , field <- fields + , termid <- DocTermIds.fieldElems docTerms field ] + where + fields = Ix.range (minBound, maxBound) + + +------------------- +-- Lookups +-- + +docCount :: SearchIndex key field feature -> Int +docCount SearchIndex{docIdMap} = IntMap.size docIdMap + +lookupTerm :: SearchIndex key field feature -> Term -> Maybe (TermId, DocIdSet) +lookupTerm SearchIndex{termMap} term = + case Map.lookup term termMap of + Nothing -> Nothing + Just (TermInfo termid docidset) -> Just (termid, docidset) + +lookupTermId :: SearchIndex key field feature -> TermId -> DocIdSet +lookupTermId SearchIndex{termIdMap, termMap} termid = + case IntMap.lookup (fromEnum termid) termIdMap of + Nothing -> error $ "lookupTermId: not found " ++ show termid + Just term -> + case Map.lookup term termMap of + Nothing -> error "lookupTermId: internal error" + Just (TermInfo _ docidset) -> docidset + +lookupDocId :: SearchIndex key field feature -> + DocId -> (key, DocTermIds field, DocFeatVals feature) +lookupDocId SearchIndex{docIdMap} docid = + case IntMap.lookup (fromEnum docid) docIdMap of + Nothing -> errNotFound + Just (DocInfo key doctermids docfeatvals) -> (key, doctermids, docfeatvals) + where + errNotFound = error $ "lookupDocId: not found " ++ show docid + +lookupDocKey :: Ord key => SearchIndex key field feature -> key -> Maybe (DocTermIds field) +lookupDocKey SearchIndex{docKeyMap, docIdMap} key = do + case Map.lookup key docKeyMap of + Nothing -> Nothing + Just docid -> + case IntMap.lookup (fromEnum docid) docIdMap of + Nothing -> error "lookupDocKey: internal error" + Just (DocInfo _key doctermids _) -> Just doctermids + + +getTerm :: SearchIndex key field feature -> TermId -> Term +getTerm SearchIndex{termIdMap} termId = + termIdMap IntMap.! fromEnum termId + +getTermId :: SearchIndex key field feature -> Term -> TermId +getTermId SearchIndex{termMap} term = + case termMap Map.! term of TermInfo termid _ -> termid + +getDocTermIds :: SearchIndex key field feature -> DocId -> DocTermIds field +getDocTermIds SearchIndex{docIdMap} docid = + case docIdMap IntMap.! fromEnum docid of + DocInfo _ doctermids _ -> doctermids + +-------------------- +-- Insert & delete +-- + +-- Procedure for adding a new doc... +-- (key, field -> [Term]) +-- alloc docid for key +-- add term occurences for docid (include rev map for termid) +-- construct indexdoc now that we have all the term -> termid entries +-- insert indexdoc + +-- Procedure for updating a doc... +-- (key, field -> [Term]) +-- find docid for key +-- lookup old terms for docid (using termid rev map) +-- calc term occurrences to add, term occurrences to delete +-- add new term occurrences, delete old term occurrences +-- construct indexdoc now that we have all the term -> termid entries +-- insert indexdoc + +-- Procedure for deleting a doc... +-- (key, field -> [Term]) +-- find docid for key +-- lookup old terms for docid (using termid rev map) +-- delete old term occurrences +-- delete indexdoc + +-- | This is the representation for documents to be added to the index. +-- Documents may +-- +type DocTerms field = field -> [Term] +type DocFeatureValues feature = feature -> Float + +insertDoc :: (Ord key, Ix field, Bounded field, Ix feature, Bounded feature) => + key -> DocTerms field -> DocFeatureValues feature -> + SearchIndex key field feature -> SearchIndex key field feature +insertDoc key userDocTerms userDocFeats si@SearchIndex{docKeyMap} + | Just docid <- Map.lookup key docKeyMap + = -- Some older version of the doc is already present in the index, + -- So we keep its docid. Now have to update the doc itself + -- and update the terms by removing old ones and adding new ones. + let oldTermsIds = getDocTermIds si docid + userDocTerms' = memoiseDocTerms userDocTerms + newTerms = docTermSet userDocTerms' + oldTerms = docTermIdsTermSet si oldTermsIds + -- We optimise for the typical case of significant overlap between + -- the terms in the old and new versions of the document. + delTerms = oldTerms `Set.difference` newTerms + addTerms = newTerms `Set.difference` oldTerms + + -- Note: adding the doc relies on all the terms being in the termMap + -- already, so we first add all the term occurences for the docid. + in checkInvariant + . insertDocIdToDocEntry docid key userDocTerms' userDocFeats + . insertTermToDocIdEntries (Set.toList addTerms) docid + . deleteTermToDocIdEntries (Set.toList delTerms) docid + $ si + + | otherwise + = -- We're dealing with a new doc, so allocate a docid for the key + let (si', docid) = allocFreshDocId si + userDocTerms' = memoiseDocTerms userDocTerms + addTerms = docTermSet userDocTerms' + + -- Note: adding the doc relies on all the terms being in the termMap + -- already, so we first add all the term occurences for the docid. + in checkInvariant + . insertDocIdToDocEntry docid key userDocTerms' userDocFeats + . insertDocKeyToIdEntry key docid + . insertTermToDocIdEntries (Set.toList addTerms) docid + $ si' + +deleteDoc :: (Ord key, Ix field, Bounded field) => + key -> + SearchIndex key field feature -> SearchIndex key field feature +deleteDoc key si@SearchIndex{docKeyMap} + | Just docid <- Map.lookup key docKeyMap + = let oldTermsIds = getDocTermIds si docid + oldTerms = docTermIdsTermSet si oldTermsIds + in checkInvariant + . deleteDocEntry docid key + . deleteTermToDocIdEntries (Set.toList oldTerms) docid + $ si + + | otherwise = si + + +---------------------------------- +-- Insert & delete support utils +-- + + +memoiseDocTerms :: (Ix field, Bounded field) => DocTerms field -> DocTerms field +memoiseDocTerms docTermsFn = + \field -> vecIndexIx vec field + where + vec = vecCreateIx docTermsFn + +docTermSet :: (Bounded t, Ix t) => DocTerms t -> Set.Set Term +docTermSet docterms = + Set.unions [ Set.fromList (docterms field) + | field <- Ix.range (minBound, maxBound) ] + +docTermIdsTermSet :: (Bounded field, Ix field) => + SearchIndex key field feature -> + DocTermIds field -> Set.Set Term +docTermIdsTermSet si doctermids = + Set.unions [ Set.fromList terms + | field <- Ix.range (minBound, maxBound) + , let termids = DocTermIds.fieldElems doctermids field + terms = map (getTerm si) termids ] + +-- +-- The Term <-> DocId mapping +-- + +-- | Add an entry into the 'Term' to 'DocId' mapping. +insertTermToDocIdEntry :: Term -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +insertTermToDocIdEntry term !docid si@SearchIndex{termMap, termIdMap, nextTermId} = + case Map.lookup term termMap of + Nothing -> + let !termInfo' = TermInfo nextTermId (DocIdSet.singleton docid) + in si { termMap = Map.insert term termInfo' termMap + , termIdMap = IntMap.insert (fromEnum nextTermId) term termIdMap + , nextTermId = succ nextTermId } + + Just (TermInfo termId docIdSet) -> + let !termInfo' = TermInfo termId (DocIdSet.insert docid docIdSet) + in si { termMap = Map.insert term termInfo' termMap } + +-- | Add multiple entries into the 'Term' to 'DocId' mapping: many terms that +-- map to the same document. +insertTermToDocIdEntries :: [Term] -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +insertTermToDocIdEntries terms !docid si = + foldl' (\si' term -> insertTermToDocIdEntry term docid si') si terms + +-- | Delete an entry from the 'Term' to 'DocId' mapping. +deleteTermToDocIdEntry :: Term -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +deleteTermToDocIdEntry term !docid si@SearchIndex{termMap, termIdMap} = + case Map.lookup term termMap of + Nothing -> si + Just (TermInfo termId docIdSet) -> + let docIdSet' = DocIdSet.delete docid docIdSet + termInfo' = TermInfo termId docIdSet' + in if DocIdSet.null docIdSet' + then si { termMap = Map.delete term termMap + , termIdMap = IntMap.delete (fromEnum termId) termIdMap } + else si { termMap = Map.insert term termInfo' termMap } + +-- | Delete multiple entries from the 'Term' to 'DocId' mapping: many terms +-- that map to the same document. +deleteTermToDocIdEntries :: [Term] -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +deleteTermToDocIdEntries terms !docid si = + foldl' (\si' term -> deleteTermToDocIdEntry term docid si') si terms + +-- +-- The DocId <-> Doc mapping +-- + +allocFreshDocId :: SearchIndex key field feature -> + (SearchIndex key field feature, DocId) +allocFreshDocId si@SearchIndex{nextDocId} = + let !si' = si { nextDocId = succ nextDocId } + in (si', nextDocId) + +insertDocKeyToIdEntry :: Ord key => key -> DocId -> + SearchIndex key field feature -> + SearchIndex key field feature +insertDocKeyToIdEntry dockey !docid si@SearchIndex{docKeyMap} = + si { docKeyMap = Map.insert dockey docid docKeyMap } + +insertDocIdToDocEntry :: (Ix field, Bounded field, + Ix feature, Bounded feature) => + DocId -> key -> + DocTerms field -> + DocFeatureValues feature -> + SearchIndex key field feature -> + SearchIndex key field feature +insertDocIdToDocEntry !docid dockey userdocterms userdocfeats + si@SearchIndex{docIdMap} = + let doctermids = DocTermIds.create (map (getTermId si) . userdocterms) + docfeatvals= DocFeatVals.create userdocfeats + !docinfo = DocInfo dockey doctermids docfeatvals + in si { docIdMap = IntMap.insert (fromEnum docid) docinfo docIdMap } + +deleteDocEntry :: Ord key => DocId -> key -> + SearchIndex key field feature -> SearchIndex key field feature +deleteDocEntry docid key si@SearchIndex{docIdMap, docKeyMap} = + si { docIdMap = IntMap.delete (fromEnum docid) docIdMap + , docKeyMap = Map.delete key docKeyMap } + diff --git a/Data/SearchEngine/TermBag.hs b/Data/SearchEngine/TermBag.hs new file mode 100644 --- /dev/null +++ b/Data/SearchEngine/TermBag.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +module Data.SearchEngine.TermBag ( + TermId, + TermBag, + size, + fromList, + elems, + termCount, + ) where + +import qualified Data.Vector.Unboxed as Vec +import qualified Data.Map as Map +import Data.Word (Word32) +import Data.Bits + +newtype TermId = TermId Word32 + deriving (Eq, Ord, Show, Enum) + +instance Bounded TermId where + minBound = TermId 0 + maxBound = TermId 0x00FFFFFF + +data TermBag = TermBag !Int !(Vec.Vector TermIdAndCount) + deriving Show + +-- We sneakily stuff both the TermId and the bag count into one 32bit word +type TermIdAndCount = Word32 + +-- Bottom 24 bits is the TermId, top 8 bits is the bag count +termIdAndCount :: TermId -> Int -> TermIdAndCount +termIdAndCount (TermId termid) freq = + (min (fromIntegral freq) 255 `shiftL` 24) + .|. (termid .&. 0x00FFFFFF) + +getTermId :: TermIdAndCount -> TermId +getTermId word = TermId (word .&. 0x00FFFFFF) + +getTermCount :: TermIdAndCount -> Int +getTermCount word = fromIntegral (word `shiftR` 24) + + +size :: TermBag -> Int +size (TermBag sz _) = sz + +elems :: TermBag -> [TermId] +elems (TermBag _ vec) = map getTermId (Vec.toList vec) + +termCount :: TermBag -> TermId -> Int +termCount (TermBag _ vec) = + binarySearch 0 (Vec.length vec - 1) + where + binarySearch :: Int -> Int -> TermId -> Int + binarySearch !a !b !key + | a > b = 0 + | otherwise = + let mid = (a + b) `div` 2 + tidAndCount = vec Vec.! mid + in case compare key (getTermId tidAndCount) of + LT -> binarySearch a (mid-1) key + EQ -> getTermCount tidAndCount + GT -> binarySearch (mid+1) b key + +fromList :: [TermId] -> TermBag +fromList termids = + let bag = Map.fromListWith (+) [ (t, 1) | t <- termids ] + sz = Map.foldl' (+) 0 bag + vec = Vec.fromListN (Map.size bag) + [ termIdAndCount termid freq + | (termid, freq) <- Map.toAscList bag ] + in TermBag sz vec + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2014 Duncan Coutts, 2014 Well-Typed LLP + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Duncan Coutts nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/full-text-search.cabal b/full-text-search.cabal new file mode 100644 --- /dev/null +++ b/full-text-search.cabal @@ -0,0 +1,68 @@ +name: full-text-search +version: 0.2.0.0 +synopsis: In-memory full text search engine +description: An in-memory full text search engine library. It lets you + run full-text queries on a collection of your documents. + . + Features: + . + * Can search over any type of \"document\". + (You explain how to extract search terms from them.) + . + * Supports documents with multiple fields + (e.g. title, body) + . + * Supports documents with non-term features + (e.g. quality score, page rank) + . + * Uses the state of the art BM25F ranking function + . + * Adjustable ranking parameters (including field weights + and non-term feature scores) + . + * In-memory but quite compact. It does not keep a copy of + your original documents. + . + It is independent of the document type, so you have to + write the document-specific parts: extracting search terms + and any case-normalisation or stemming. This is quite + easy using libraries such as + and + . + . + For an example, see the code for the + + where it is used for the package search feature. + +license: BSD3 +license-file: LICENSE +author: Duncan Coutts +maintainer: Duncan Coutts +copyright: 2013-2014 Duncan Coutts, 2014 Well-Typed LLP +category: Data, Text, NLP +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: darcs + location: http://code.haskell.org/full-text-search/ + +library + exposed-modules: Data.SearchEngine, + Data.SearchEngine.BM25F + other-modules: Data.SearchEngine.DocFeatVals, + Data.SearchEngine.TermBag, + Data.SearchEngine.DocTermIds, + Data.SearchEngine.SearchIndex, + Data.SearchEngine.DocIdSet + other-extensions: BangPatterns, + NamedFieldPuns, + RecordWildCards, + GeneralizedNewtypeDeriving + build-depends: base >=4.5 && <4.7, + array >=0.4 && <0.5, + vector >=0.10 && <0.11, + containers >=0.4 && <0.6, + text >=0.11 && <1.2 + default-language: Haskell2010 + ghc-options: -Wall