Place exact package matches at the start of search results.

Closes #397

Author: mpickering

Distribution/Server/Features/Search/PkgSearch.hs

@@ -22,6 +22,7 @@ import NLP.Snowball
 import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.Text (display)
+import Data.Text (unpack)
 
 
 type PkgSearchEngine = SearchEngine
@@ -50,7 +51,8 @@ pkgSearchConfig =
       documentKey           = packageName . fst,
       extractDocumentTerms  = extractTokens . fst,
       transformQueryTerm    = normaliseQueryToken,
-      documentFeatureValue  = getFeatureValue
+      documentFeatureValue  = getFeatureValue,
+      makeKey               = PackageName . unpack
   }
   where
     extractTokens :: PackageDescription -> PkgDocField -> [Text]

Distribution/Server/Features/Search/SearchEngine.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns, NamedFieldPuns, RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Distribution.Server.Features.Search.SearchEngine (
     SearchEngine,
@@ -55,7 +56,9 @@ data SearchConfig doc key field feature = SearchConfig {
        documentKey          :: doc -> key,
        extractDocumentTerms :: doc -> field -> [Term],
        transformQueryTerm   :: Term -> field -> Term,
-       documentFeatureValue :: doc -> feature -> Float
+       documentFeatureValue :: doc -> feature -> Float,
+       makeKey :: Term -> key
+
      }
 
 data SearchRankParameters field feature = SearchRankParameters {
@@ -204,11 +207,11 @@ deleteDoc key se@SearchEngine{searchIndex} =
         updateCachedFieldLengths oldDoc Nothing $
           se { searchIndex = searchIndex' }
 
-query :: (Ix field, Bounded field, Ix feature, Bounded feature) =>
+query :: (Ix field, Bounded field, Ix feature, Bounded feature, Ord key) =>
          SearchEngine doc key field feature ->
          [Term] -> [key]
 query se@SearchEngine{ searchIndex,
-                       searchConfig     = SearchConfig{transformQueryTerm},
+                       searchConfig     = SearchConfig{transformQueryTerm, makeKey},
                        searchRankParams = SearchRankParameters{..} }
       terms =
 
@@ -223,9 +226,16 @@ query se@SearchEngine{ searchIndex,
                     ]
 
       -- Then we look up all the normalised terms in the index.
-      rawresults :: [Maybe (TermId, DocIdSet)] 
+      rawresults :: [Maybe (TermId, DocIdSet)]
       rawresults = map (SI.lookupTerm searchIndex) lookupTerms
 
+      -- Check if there is one term then it exactly matches a package
+      exactMatch :: Maybe DocId
+      exactMatch = case terms of
+                     [] -> Nothing
+                     [x] -> SI.lookupDocKeyReal searchIndex (makeKey x)
+                     (_:_) -> Nothing
+
       -- 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]
@@ -254,17 +264,24 @@ query se@SearchEngine{ searchIndex,
       -- 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)
+   in rankResults se exactMatch termids (DocIdSet.toList unrankedResults)
 
-rankResults :: (Ix field, Bounded field, Ix feature, Bounded feature) =>
-               SearchEngine doc key field feature ->
+rankResults :: forall field key feature doc .
+               (Ix field, Bounded field, Ix feature, Bounded feature) =>
+               SearchEngine doc key field feature -> Maybe DocId ->
                [TermId] -> [DocId] -> [key]
-rankResults se@SearchEngine{searchIndex} queryTerms docids =
-    map snd
-  $ sortBy (flip compare `on` fst)
+rankResults se@SearchEngine{searchIndex} exactMatch queryTerms docids =
+    maybe id prependExactMatch exactMatch (map snd
+    $ sortBy (flip compare `on` fst)
       [ (relevanceScore se queryTerms doctermids docfeatvals, dockey)
       | docid <- docids
-      , let (dockey, doctermids, docfeatvals) = SI.lookupDocId searchIndex docid ]
+      , maybe True (/= docid) exactMatch
+      , let (dockey, doctermids, docfeatvals) = SI.lookupDocId searchIndex docid ])
+  where
+    prependExactMatch :: DocId -> [key] -> [key]
+    prependExactMatch docid keys = dockey : keys
+      where
+        (dockey, _, _) = SI.lookupDocId searchIndex docid
 
 relevanceScore :: (Ix field, Bounded field, Ix feature, Bounded feature) =>
                   SearchEngine doc key field feature ->

Distribution/Server/Features/Search/SearchIndex.hs

@@ -15,9 +15,10 @@ module Distribution.Server.Features.Search.SearchIndex (
     lookupTermId,
     lookupDocId,
     lookupDocKey,
-    
+    lookupDocKeyReal,
+
     getTerm,
-    
+
     invariant,
   ) where
 
@@ -170,14 +171,16 @@ lookupDocId SearchIndex{docIdMap} docid =
     errNotFound = error $ "lookupDocId: not found " ++ show docid
 
 lookupDocKey :: Ord key => SearchIndex key field feature -> key -> Maybe (DocTermIds field)
-lookupDocKey SearchIndex{docKeyMap, docIdMap} key = do
+lookupDocKey SearchIndex{docKeyMap, docIdMap} key =
     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
+          Just (DocInfo _ doctermids _) -> Just doctermids
 
+lookupDocKeyReal :: Ord key => SearchIndex key field feature -> key -> Maybe DocId
+lookupDocKeyReal SearchIndex{docKeyMap} key = Map.lookup key docKeyMap
 
 getTerm :: SearchIndex key field feature -> TermId -> Term
 getTerm SearchIndex{termIdMap} termId =