blob: 181a3e8a4122e1b5261d503c86c1e2bf358055ff (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
;;; guile-xapian --- Guile bindings for Xapian
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of guile-xapian.
;;;
;;; guile-xapian is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 2 of the
;;; License, or (at your option) any later version.
;;;
;;; guile-xapian is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with guile-xapian. If not, see
;;; <https://www.gnu.org/licenses/>.
(define-module (xapian xapian)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (xapian wrap)
#:export (xapian-open
xapian-close
call-with-database
database-document-count
xapian-open-writable
xapian-close-writable
call-with-writable-database
add-document!
replace-document!
make-document
document-data
make-stem
make-term-generator
index-text!
increase-termpos!
parse-query
enquire
enquire-mset
mset-item-docid
mset-item-document
mset-item-rank
mset-item-weight
mset-fold))
(define xapian-open new-Database)
(define xapian-close delete-Database)
(define (call-with-database dbpath proc)
(let ((db (xapian-open dbpath)))
(dynamic-wind noop (cut proc db) (cut xapian-close db))))
(define database-document-count Database-get-doccount)
(define xapian-open-writable new-WritableDatabase)
(define xapian-close-writable delete-WritableDatabase)
(define (call-with-writable-database dbpath proc)
(let ((db (xapian-open-writable dbpath)))
(dynamic-wind noop (cut proc db) (cut xapian-close-writable db))))
(define add-document! WritableDatabase-add-document)
(define replace-document! WritableDatabase-replace-document)
(define* (make-document #:key data (terms '()))
(let ((doc (new-Document)))
(when data
(Document-set-data doc data))
(for-each (match-lambda
((term . wdf-increment)
(Document-add-term doc term wdf-increment)))
terms)
doc))
(define document-data Document-get-data)
(define make-stem new-Stem)
(define* (make-term-generator #:key stem document)
(let ((term-generator (new-TermGenerator)))
(TermGenerator-set-stemmer term-generator stem)
(TermGenerator-set-document term-generator document)
term-generator))
(define* (index-text! term-generator text #:key (wdf-increment 1) prefix)
(apply TermGenerator-index-text term-generator text wdf-increment
(if prefix (list prefix) '())))
(define increase-termpos! TermGenerator-increase-termpos)
(define* (parse-query querystring #:key stemmer stemming-strategy (prefixes '()))
(let ((queryparser (new-QueryParser)))
(QueryParser-set-stemmer queryparser stemmer)
(when stemming-strategy
(QueryParser-set-stemming-strategy queryparser stemming-strategy))
(for-each (match-lambda
((field . prefix)
(QueryParser-add-prefix queryparser field prefix)))
prefixes)
(let ((query (QueryParser-parse-query queryparser querystring)))
(delete-QueryParser queryparser)
query)))
(define* (enquire db query #:key weighting-scheme)
(let ((enquire (new-Enquire db)))
(Enquire-set-query enquire query)
(when weighting-scheme
(Enquire-set-weighting-scheme enquire weighting-scheme))
enquire))
(define enquire-mset Enquire-get-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))))))
|
