summaryrefslogtreecommitdiff
path: root/xapian/xapian.scm
blob: 8801838bf9c9e3ac03222b5da6e4554056ba6221 (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
;;; 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
            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 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))))))