summaryrefslogtreecommitdiff
path: root/xapian/xapian.scm
diff options
context:
space:
mode:
authorArun Isaac2020-02-15 19:25:30 +0530
committerArun Isaac2020-02-15 19:34:29 +0530
commit9a1bfc6980fb492149ad795330f0d5b17a3b59cf (patch)
tree54a017fb98582e2c5f1160c08411df58aaa60e98 /xapian/xapian.scm
downloadguile-xapian-9a1bfc6980fb492149ad795330f0d5b17a3b59cf.tar.gz
guile-xapian-9a1bfc6980fb492149ad795330f0d5b17a3b59cf.tar.lz
guile-xapian-9a1bfc6980fb492149ad795330f0d5b17a3b59cf.zip
First commit.
Diffstat (limited to 'xapian/xapian.scm')
-rw-r--r--xapian/xapian.scm124
1 files changed, 124 insertions, 0 deletions
diff --git a/xapian/xapian.scm b/xapian/xapian.scm
new file mode 100644
index 0000000..8801838
--- /dev/null
+++ b/xapian/xapian.scm
@@ -0,0 +1,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))))))