diff options
Diffstat (limited to 'xapian')
| -rw-r--r-- | xapian/xapian.scm | 241 |
1 files changed, 222 insertions, 19 deletions
diff --git a/xapian/xapian.scm b/xapian/xapian.scm index 80b4b9b..c744101 100644 --- a/xapian/xapian.scm +++ b/xapian/xapian.scm @@ -1,5 +1,5 @@ ;;; guile-xapian --- Guile bindings for Xapian -;;; Copyright © 2020, 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2020, 2022, 2024–2026 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2021 Bob131 <bob@bob131.so> ;;; ;;; This file is part of guile-xapian. @@ -23,6 +23,7 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (htmlprag) #:use-module (xapian wrap) @@ -45,14 +46,24 @@ document-slot-ref-bytes document-slot-set! document-slot-set-bytes! + document-termlist make-stem make-term-generator index-text! increase-termpos! parse-query + query query-and query-or + query-xor query-filter + query-phrase + query-termlist + prefixed-range-processor + suffixed-range-processor + prefixed-date-range-processor + suffixed-date-range-processor + field-processor enquire enquire-mset mset-item-docid @@ -60,9 +71,22 @@ mset-item-rank mset-item-weight mset-fold + termlist-fold + positionlist-fold + term-string + term-wdf + term-freq + term-positionlist + position-termpos mset-snippet mset-sxml-snippet)) +(define-record-type <iterable> + (iterable start end) + iterable? + (start iterable-start) + (end iterable-end)) + (define xapian-open new-Database) (define xapian-close delete-Database) @@ -140,6 +164,10 @@ bytevector." (current-error-port)) (Document-add-value-bytes document slot value)) +(define (document-termlist doc) + (iterable (Document-termlist-begin doc) + (Document-termlist-end doc))) + (define make-stem new-Stem) (define* (make-term-generator #:key stem document) @@ -160,7 +188,48 @@ generated." (define increase-termpos! TermGenerator-increase-termpos) -(define* (parse-query querystring #:key stemmer stemming-strategy (prefixes '())) +(define* (parse-query querystring + #:key + stemmer + stemming-strategy + (prefixes '()) + (boolean-prefixes '()) + (range-processors '()) + (default-operator (Query-OP-OR)) + (boolean? #t) + (phrases? #t) + (love-hate? #t) + any-case-boolean? + wildcard? + pure-not? + partial?) + "Parse @var{querystring} and return a @code{Query} object. + +@var{prefixes} and @var{boolean-prefixes} must be association lists +mapping fields to prefixes or @code{FieldProcessor} +objects. @var{range-processors} is a list of @code{RangeProcessor} +objects. + +Use @code{default-operator} to combine non-filter query items when no +explicit operator is used. + +When @var{boolean?} is @code{#t}, boolean operators (AND, OR, etc.) +and bracketed subexpressions are supported. + +When @var{phrases?} is @code{#t}, quoted phrases are supported. + +When @var{love-hate?} is @code{#t}, @samp{+} and @samp{-} are +supported. + +When @var{any-case-boolean?} is @code{#t}, boolean operators are +supported even if they are not in capitals. + +When @var{wildcard?} is @code{#t}, wildcards are supported. + +When @var{pure-not?} is @code{#t}, pure @code{NOT} queries such as +@samp{NOT apples} are allowed. + +When @var{partial?} is @code{#t}, enable partial matching." (let ((queryparser (new-QueryParser))) (QueryParser-set-stemmer queryparser stemmer) (when stemming-strategy @@ -169,7 +238,22 @@ generated." ((field . prefix) (QueryParser-add-prefix queryparser field prefix))) prefixes) - (let ((query (QueryParser-parse-query queryparser querystring))) + (for-each (match-lambda + ((field . prefix) + (QueryParser-add-boolean-prefix queryparser field prefix))) + boolean-prefixes) + (for-each (cut QueryParser-add-rangeprocessor queryparser <>) + range-processors) + (QueryParser-set-default-op queryparser default-operator) + (let ((query (QueryParser-parse-query queryparser + querystring + (bitwise-ior (get-flag QueryParser-FLAG-BOOLEAN boolean?) + (get-flag QueryParser-FLAG-PHRASE phrases?) + (get-flag QueryParser-FLAG-LOVEHATE love-hate?) + (get-flag QueryParser-FLAG-BOOLEAN-ANY-CASE any-case-boolean?) + (get-flag QueryParser-FLAG-WILDCARD wildcard?) + (get-flag QueryParser-FLAG-PURE-NOT pure-not?) + (get-flag QueryParser-FLAG-PARTIAL partial?))))) (delete-QueryParser queryparser) query))) @@ -190,33 +274,55 @@ result set. MAXIMUM-ITEMS specifies the maximum number of items to return. To return all matches, pass the result of calling database-document-count on the database object." - (Enquire-get-mset enquire offset maximum-items)) + (let ((mset (Enquire-get-mset enquire offset maximum-items))) + (iterable (MSet-begin mset) + (MSet-end mset)))) (define mset-item-docid MSetIterator-get-docid) (define mset-item-document MSetIterator-get-document) (define mset-item-rank MSetIterator-get-rank) (define mset-item-weight MSetIterator-get-weight) -(define (mset-fold proc init mset) - (let loop ((head (MSet-begin mset)) - (result init)) - (cond - ((MSetIterator-equals head (MSet-end mset)) result) - (else (let ((result (proc head result))) - (MSetIterator-next head) - (loop head result)))))) +(define (iterator->fold iterator-next iterator-equals) + (lambda (proc init iterable) + (let loop ((head (iterable-start iterable)) + (result init)) + (cond + ((iterator-equals head (iterable-end iterable)) result) + (else + (let ((result (proc head result))) + (iterator-next head) + (loop head result))))))) + +(define mset-fold + (iterator->fold MSetIterator-next MSetIterator-equals)) -(define (query-combine combine-operator default . queries) - (reduce (cut new-Query combine-operator <> <>) - default - queries)) +(define termlist-fold + (iterator->fold TermIterator-next TermIterator-equals)) + +(define positionlist-fold + (iterator->fold PositionIterator-next PositionIterator-equals)) + +(define term-string TermIterator-get-term) +(define term-wdf TermIterator-get-wdf) +(define term-freq TermIterator-get-termfreq) + +(define (term-positionlist term) + (iterable (TermIterator-positionlist-begin term) + (TermIterator-positionlist-end term))) + +(define position-termpos PositionIterator-get-termpos) + +(define (query term) + "Return a @code{Query} object for @var{term}." + (new-Query term)) (define (query-and . queries) "Return a query matching only documents matching all @var{queries}. In a weighted context, the weight is the sum of the weights for all queries." - (apply query-combine (Query-OP-AND) (Query-MatchAll) queries)) + (guile-xapian-build-query (Query-OP-AND) queries)) (define (query-or . queries) "Return a query matching documents which at least one of @var{queries} @@ -224,7 +330,15 @@ match. In a weighted context, the weight is the sum of the weights for matching queries." - (apply query-combine (Query-OP-OR) (Query-MatchNothing) queries)) + (guile-xapian-build-query (Query-OP-OR) queries)) + +(define (query-xor . queries) + "Return a query matching documents which an odd number of @var{queries} +match. + +In a weighted context, the weight is the sum of the weights for +matching queries." + (guile-xapian-build-query (Query-OP-XOR) queries)) (define (query-filter . queries) "Return a query matching only documents matching all @var{queries}, @@ -232,7 +346,96 @@ but only take weight from the first of @var{queries}. In a non-weighted context, @code{query-filter} and @code{query-and} are equivalent." - (apply query-combine (Query-OP-FILTER) (Query-MatchAll) queries)) + (guile-xapian-build-query (Query-OP-FILTER) queries)) + +(define (query-phrase . queries) + "Return a query matching only documents where all @var{queries} match +near and in order. All queries must be single-term +queries (constructed using @code{query}) or single-term queries +composed with @code{query-or}. + +In a weighted context, the weight is the sum of the weights for all +queries." + (guile-xapian-build-query (Query-OP-PHRASE) queries)) + +(define (query-termlist query) + (iterable (Query-get-terms-begin query) + (Query-get-terms-end query))) + +(define* (prefixed-range-processor slot proc #:key (prefix "") repeated?) + "Return a @code{RangeProcessor} object that calls @var{proc} to process +its range over @var{slot}. + +@var{proc} is a procedure that, given a begin string and an end +string, must return a @code{Query} object. For open-ended ranges, +either the begin string or the end string will be @code{#f}. + +@var{prefix} is a prefix to look for to recognize values as belonging +to this range. When @var{repeated?} is @code{#t}, allow @var{prefix} +on both ends of the range---@samp{$1..$10}." + (new-GuileXapianRangeProcessorWrapper + slot + prefix + (get-flag RP-REPEATED repeated?) + proc)) + +(define* (suffixed-range-processor slot proc #:key suffix repeated?) + "Return a @code{RangeProcessor} object that calls @var{proc} to process +its range over @var{slot}. + +@var{proc} is a procedure that, given a begin string and an end +string, must return a @code{Query} object. For open-ended ranges, +either the begin string or the end string will be @code{#f}. + +@var{suffix} is a suffix to look for to recognize values as belonging +to this range. When @var{repeated?} is @code{#t}, allow @var{suffix} +on both ends of the range—@samp{2kg..12kg}." + (new-GuileXapianRangeProcessorWrapper + slot + suffix + (bitwise-ior (RP-SUFFIX) + (get-flag RP-REPEATED repeated?)) + proc)) + +(define* (prefixed-date-range-processor slot #:key (prefix "") repeated? prefer-mdy? (epoch-year 1970)) + "Return a @code{DateRangeProcessor} object that handles date ranges on +@var{slot}. + +@var{prefix} and @var{repeated?} are the same as in +@code{prefixed-range-processor}. + +When @var{prefer-mdy?} is @code{#t}, interpret ambiguous dates as +month/day/year rather than day/month/year. + +@var{epoch-year} is the year to use as the epoch for dates with +two-digit years." + (new-DateRangeProcessor slot + prefix + (bitwise-ior (get-flag RP-REPEATED repeated?) + (get-flag RP-DATE-PREFER-MDY prefer-mdy?)) + epoch-year)) + +(define* (suffixed-date-range-processor slot #:key suffix repeated? prefer-mdy? (epoch-year 1970)) + "Return a @code{DateRangeProcessor} object that handles date ranges on +@var{slot}. + +@var{suffix} and @var{repeated?} are the same as in +@code{suffixed-range-processor}. + +@var{prefer-mdy?} and @var{epoch-year} are the same as in +@code{prefixed-date-range-processor}." + (new-DateRangeProcessor slot + suffix + (bitwise-ior (RP-SUFFIX) + (get-flag RP-REPEATED repeated?) + (get-flag RP-DATE-PREFER-MDY prefer-mdy?)) + epoch-year)) + +(define (field-processor proc) + "Return a @code{FieldProcessor} object that calls +@var{proc} to process its field. @var{proc} is a procedure that, given +a string, must return a @code{Query} object." + (new-GuileXapianFieldProcessorWrapper proc)) (define (get-flag flag-thunk value) (if value (flag-thunk) 0)) |